Mercurial > octave-nkf
changeset 14162:969532305835
maint: periodic merge of stable to default
| author | John W. Eaton <jwe@octave.org> |
|---|---|
| date | Fri, 06 Jan 2012 12:43:48 -0500 |
| parents | e530656055ae (current diff) f4b5a2f899d3 (diff) |
| children | df695e37d404 67a0ab9f8283 |
| files | libcruft/arpack/LICENSE libcruft/arpack/README libcruft/arpack/docs/README libcruft/arpack/docs/debug.doc libcruft/arpack/docs/ex-complex.doc libcruft/arpack/docs/ex-nonsym.doc libcruft/arpack/docs/ex-sym.doc libcruft/arpack/docs/stat.doc libcruft/arpack/module.mk libcruft/arpack/src/cgetv0.f libcruft/arpack/src/cnaitr.f libcruft/arpack/src/cnapps.f libcruft/arpack/src/cnaup2.f libcruft/arpack/src/cnaupd.f libcruft/arpack/src/cneigh.f libcruft/arpack/src/cneupd.f libcruft/arpack/src/cngets.f libcruft/arpack/src/csortc.f libcruft/arpack/src/cstatn.f libcruft/arpack/src/debug.h libcruft/arpack/src/dgetv0.f libcruft/arpack/src/dlaqrb.f libcruft/arpack/src/dnaitr.f libcruft/arpack/src/dnapps.f libcruft/arpack/src/dnaup2.f libcruft/arpack/src/dnaupd.f libcruft/arpack/src/dnconv.f libcruft/arpack/src/dneigh.f libcruft/arpack/src/dneupd.f libcruft/arpack/src/dngets.f libcruft/arpack/src/dsaitr.f libcruft/arpack/src/dsapps.f libcruft/arpack/src/dsaup2.f libcruft/arpack/src/dsaupd.f libcruft/arpack/src/dsconv.f libcruft/arpack/src/dseigt.f libcruft/arpack/src/dsesrt.f libcruft/arpack/src/dseupd.f libcruft/arpack/src/dsgets.f libcruft/arpack/src/dsortc.f libcruft/arpack/src/dsortr.f libcruft/arpack/src/dstatn.f libcruft/arpack/src/dstats.f libcruft/arpack/src/dstqrb.f libcruft/arpack/src/sgetv0.f libcruft/arpack/src/slaqrb.f libcruft/arpack/src/snaitr.f libcruft/arpack/src/snapps.f libcruft/arpack/src/snaup2.f libcruft/arpack/src/snaupd.f libcruft/arpack/src/snconv.f libcruft/arpack/src/sneigh.f libcruft/arpack/src/sneupd.f libcruft/arpack/src/sngets.f libcruft/arpack/src/ssaitr.f libcruft/arpack/src/ssapps.f libcruft/arpack/src/ssaup2.f libcruft/arpack/src/ssaupd.f libcruft/arpack/src/ssconv.f libcruft/arpack/src/sseigt.f libcruft/arpack/src/ssesrt.f libcruft/arpack/src/sseupd.f libcruft/arpack/src/ssgets.f libcruft/arpack/src/ssortc.f libcruft/arpack/src/ssortr.f libcruft/arpack/src/sstatn.f libcruft/arpack/src/sstats.f libcruft/arpack/src/sstqrb.f libcruft/arpack/src/stat.h libcruft/arpack/src/version.h libcruft/arpack/src/zgetv0.f libcruft/arpack/src/znaitr.f libcruft/arpack/src/znapps.f libcruft/arpack/src/znaup2.f libcruft/arpack/src/znaupd.f libcruft/arpack/src/zneigh.f libcruft/arpack/src/zneupd.f libcruft/arpack/src/zngets.f libcruft/arpack/src/zsortc.f libcruft/arpack/src/zstatn.f libcruft/arpack/util/cmout.f libcruft/arpack/util/cvout.f libcruft/arpack/util/dmout.f libcruft/arpack/util/dvout.f libcruft/arpack/util/icnteq.f libcruft/arpack/util/icopy.f libcruft/arpack/util/iset.f libcruft/arpack/util/iswap.f libcruft/arpack/util/ivout.f libcruft/arpack/util/second.f libcruft/arpack/util/smout.f libcruft/arpack/util/svout.f libcruft/arpack/util/zmout.f libcruft/arpack/util/zvout.f |
| diffstat | 126 files changed, 698 insertions(+), 36401 deletions(-) [+] |
line wrap: on
line diff
--- a/.hgsubstate Mon Jan 02 15:19:45 2012 -0500 +++ b/.hgsubstate Fri Jan 06 12:43:48 2012 -0500 @@ -1,1 +1,1 @@ -bb052d4a7416accaad0747e84bd2a0accbfcf923 gnulib +3559997a03e82d650aaa708447362fe20a6eaf15 gnulib
--- a/build-aux/bootstrap.conf Mon Jan 02 15:19:45 2012 -0500 +++ b/build-aux/bootstrap.conf Fri Jan 06 12:43:48 2012 -0500 @@ -36,6 +36,7 @@ getopt-gnu gettimeofday glob + isatty link lstat mkdir @@ -48,8 +49,10 @@ opendir pathmax progname + readdir readlink rename + rewinddir rmdir round roundf
--- a/build-aux/common.mk Mon Jan 02 15:19:45 2012 -0500 +++ b/build-aux/common.mk Fri Jan 06 12:43:48 2012 -0500 @@ -243,6 +243,10 @@ READLINE_LIBS = @READLINE_LIBS@ TERM_LIBS = @TERM_LIBS@ +ARPACK_CPPFLAGS = @ARPACK_CPPFLAGS@ +ARPACK_LDFLAGS = @ARPACK_LDFLAGS@ +ARPACK_LIBS = @ARPACK_LIBS@ + DL_LIBS = @DL_LIBS@ LIBS = @LIBS@ @@ -452,6 +456,9 @@ -e "s|%OCTAVE_CONF_AMD_LIBS%|\"${AMD_LIBS}\"|" \ -e "s|%OCTAVE_CONF_AR%|\"${AR}\"|" \ -e "s|%OCTAVE_CONF_ARFLAGS%|\"${ARFLAGS}\"|" \ + -e "s|%OCTAVE_CONF_ARPACK_CPPFLAGS%|\"${ARPACK_CPPFLAGS}\"|" \ + -e "s|%OCTAVE_CONF_ARPACK_LDFLAGS%|\"${ARPACK_LDFLAGS}\"|" \ + -e "s|%OCTAVE_CONF_ARPACK_LIBS%|\"${ARPACK_LIBS}\"|" \ -e "s|%OCTAVE_CONF_BLAS_LIBS%|\"${BLAS_LIBS}\"|" \ -e "s|%OCTAVE_CONF_CAMD_CPPFLAGS%|\"${CAMD_CPPFLAGS}\"|" \ -e "s|%OCTAVE_CONF_CAMD_LDFLAGS%|\"${CAMD_LDFLAGS}\"|" \
--- a/configure.ac Mon Jan 02 15:19:45 2012 -0500 +++ b/configure.ac Fri Jan 06 12:43:48 2012 -0500 @@ -1173,6 +1173,19 @@ LIBS="$save_LIBS" fi +save_LIBS="$LIBS" +LIBS="$LAPACK_LIBS $BLAS_LIBS $FLIBS $LIBS" +OCTAVE_CHECK_LIBRARY(arpack, ARPACK, + [ARPACK not found. The eigs function will be disabled.], + [], + [dseupd], + [Fortran 77], [don't use the ARPACK library, disable eigs function], + [warn_arpack= + OCTAVE_CHECK_ARPACK_OK([ + AC_DEFINE(HAVE_ARPACK, 1, [Define if ARPACK is available.])], [ + warn_arpack="ARPACK library found, but seems not to work properly -- disabling eigs function"])]) +LIBS="$save_LIBS" + ### Enable dynamic linking. --enable-shared implies this, so ### --enable-dl is only need if you are only building static libraries ### and want to try dynamic linking too (works on some systems, for @@ -1613,7 +1626,7 @@ AC_CHECK_FUNCS(basename canonicalize_file_name \ chmod dup2 endgrent endpwent execvp expm1 expm1f fork \ getegid geteuid getgid getgrent getgrgid getgrnam getpgrp getpid \ - getppid getpwent getpwuid getuid getwd _kbhit kill \ + getppid getpwent getpwuid getuid getwd _kbhit \ lgamma lgammaf lgamma_r lgammaf_r localtime_r log1p log1pf \ mkstemp pipe putenv \ realpath resolvepath rindex roundl select setgrent setlocale \ @@ -2150,6 +2163,9 @@ AMD CPPFLAGS: $AMD_CPPFLAGS AMD LDFLAGS: $AMD_LDFLAGS AMD libraries: $AMD_LIBS + ARPACK CPPFLAGS: $ARPACK_CPPFLAGS + ARPACK LDFLAGS: $ARPACK_LDFLAGS + ARPACK libraries: $ARPACK_LIBS BLAS libraries: $BLAS_LIBS CAMD CPPFLAGS: $CAMD_CPPFLAGS CAMD LDFLAGS: $CAMD_LDFLAGS @@ -2395,7 +2411,7 @@ AC_MSG_WARN([Make. This should work automatically for gfortran. If]) AC_MSG_WARN([you use another compiler, you will need to set this]) AC_MSG_WARN([variable on the configure command line. You must also]) - AC_MSG_WARN([compile the BLAS, LAPACK, QRUPDATE, and SuiteSparse]) + AC_MSG_WARN([compile the ARPACK, BLAS, LAPACK, QRUPDATE, and SuiteSparse]) AC_MSG_WARN([libraries to use 8 byte signed integers for array indexing.]) AC_MSG_WARN([]) warn_msg_printed=true
--- a/doc/interpreter/contrib.txi Mon Jan 02 15:19:45 2012 -0500 +++ b/doc/interpreter/contrib.txi Fri Jan 06 12:43:48 2012 -0500 @@ -1,3 +1,4 @@ +@c Copyright (C) 2012 John W. Eaton @c Copyright (C) 2008-2012 Jaroslav Hajek @c @c This file is part of Octave. @@ -25,6 +26,8 @@ @menu * How to Contribute:: +* Building the Development Sources:: +* Basics of Generating a Changeset:: * General Guidelines:: * Octave Sources (m-files):: * C++ Sources:: @@ -41,6 +44,86 @@ (@url{http://octave.sf.net}). Note that the Octave project is inherently more conservative and follows narrower rules. +@node Building the Development Sources +@section Building the Development Sources + +In addition to all the tools (both optional and required) that are +listed in @ref{Build Dependencies} you will need: + +@table @asis +@item Mercurial +Distributed version control system (@url{http://mercurial.selenic.com}). +Octave's sources are stored in a Mercurial archive. + +@item Git +Distributed version control system (@url{http://git-scm.com}). The +gnulib sources that Octave depends on are stored in a Git archive. +@end table + +Once you have the required tools installed, you can build Octave by +doing + +@itemize @bullet +@item +Check out a copy of the Octave sources: +@example +hg clone http://hg.savannah.gnu.org/hgweb/octave +@end example + +@item +Change to the top-level directory of the newly checked out sources: +@example +cd octave +@end example + +@item +Generate the necessary configuration files: +@example +./autogen.sh +@end example + +@item +Create a build directory and change to it: +@example +mkdir build +cd build +@end example +By using a separate build directory, you will keep the source directory +clean and it will be easy to completely remove all files generated by +the build. You can also have parallel build trees for different +purposes that all share the same sources. For example, one build tree +may be configured to disable compiler optimization in order to allow for +easier debugging while another may be configured to test building with +other specialized compiler flags. + +@item +Run Octave's configure script from the build directory: +@example +../configure +@end example + +@item +Run make in the build directory: +@example +make +@end example +@end itemize + +Once the build is finished, you will see a message like the following: + +@example +@group +Octave successfully built. Now choose from the following: + + ./run-octave - to run in place to test before installing + make check - to run the tests + make install - to install (PREFIX=...) +@end group +@end example + +@node Basics of Generating a Changeset +@section Basics of Generating a Changeset + The preferable form of contribution is creating a Mercurial changeset and sending it via e-mail to the octave-maintainers mailing list. Mercurial is the source code management system currently used to develop
--- a/doc/interpreter/expr.txi Mon Jan 02 15:19:45 2012 -0500 +++ b/doc/interpreter/expr.txi Fri Jan 06 12:43:48 2012 -0500 @@ -519,8 +519,7 @@ @item @var{x} + @var{y} @opindex + Addition. If both operands are matrices, the number of rows and columns -must both agree. If one operand is a scalar, its value is added to -all the elements of the other operand. +must both agree, or they must be broadcastable to the same shape. @item @var{x} .+ @var{y} @opindex .+ @@ -529,20 +528,23 @@ @item @var{x} - @var{y} @opindex - Subtraction. If both operands are matrices, the number of rows and -columns of both must agree. +columns of both must agree, or they must be broadcastable to the same +shape. @item @var{x} .- @var{y} Element by element subtraction. This operator is equivalent to @code{-}. @item @var{x} * @var{y} @opindex * -Matrix multiplication. The number of columns of @var{x} must agree -with the number of rows of @var{y}. +Matrix multiplication. The number of columns of @var{x} must agree with +the number of rows of @var{y}, or they must be broadcastable to the same +shape. @item @var{x} .* @var{y} @opindex .* -Element by element multiplication. If both operands are matrices, the -number of rows and columns must both agree. +Element by element multiplication. If both operands are matrices, the +number of rows and columns must both agree, or they must be +broadcastable to the same shape. @item @var{x} / @var{y} @opindex / @@ -599,8 +601,9 @@ @itemx @var{x} .** @var{y} @opindex .** @opindex .^ -Element by element power operator. If both operands are matrices, the -number of rows and columns must both agree. +Element by element power operator. If both operands are matrices, the +number of rows and columns must both agree, or they must be +broadcastable to the same shape. @item -@var{x} @opindex -
--- a/doc/interpreter/install.txi Mon Jan 02 15:19:45 2012 -0500 +++ b/doc/interpreter/install.txi Fri Jan 06 12:43:48 2012 -0500 @@ -44,7 +44,188 @@ @cindex installing Octave The procedure for installing Octave from source on a Unix-like system is -described below. Building on other platforms will follow similar steps. +described below. Building on other platforms will follow similar +steps. Note that this description applies to Octave releases. Building +the development sources from the Mercurial archive requires additional +steps as described in @ref{Building the Development Sources}. + +@menu +* Build Dependencies:: +* Running Configure and Make:: +* Compiling Octave with 64-bit Indexing:: +* Installation Problems:: +@end menu + +@node Build Dependencies +@section Build Dependencies + +Octave is a fairly large program with many build dependencies. You may +be able to find pre-packaged versions of the dependencies distributed as +part of your system, or you may have to build some or all of them +yourself. + +The following tools are required: + +@table @asis +@item C++, C, and Fortran compilers +The Octave sources are primarily written in C++, but some portions are +also written in C and Fortran. The Octave sources are intended to be +portable. Recent versions of the GNU compiler collection (GCC) should +work (@url{http://gcc.gnu.org}). If you use GCC, you should avoid +mixing versions. For example, be sure that you are not using the +obsolete @code{g77} Fortran compiler with modern versions of @code{gcc} +and @code{g++}. + +@item GNU Make +Tool for building software (@url{http://www.gnu.org/software/make}). +Octave's build system requires GNU Make. Other versions of Make will +not work. Fortunately, GNU Make is highly portable and easy to install. + +@item AWK, sed, and other Unix utilities +Basic Unix system utilities are required for building Octave. All will +be available with any modern Unix system and also on Windows with either +Cygwin or MinGW and MSYS. +@end table + +Additionally, the following tools may be needed: + +@table @asis +@item Bison +Parser generator (@url{http://www.gnu.org/software/bison}). +You will need Bison if you modify the @code{oct-parse.yy} source file or +if you delete the files that are generated from it. + +@item Flex +Lexer analyzer (@url{http://www.gnu.org/software/flex}). You will need +Flex if you modify the @code{lex.ll} source file or if you delete the +files that are generated from it. + +@item Autoconf +Package for software configuration +(@url{http://www.gnu.org/software/autoconf}). Autoconf is required if +you modify Octave's @code{configure.ac} file or other files that it +requires. + +@item Automake +Package for Makefile generation +(@url{http://www.gnu.org/software/automake}). Automake is required if +you modify Octave's @code{Makefile.am} files or other files that they +depend on. + +@item Libtool +Package for building software libraries +(@url{http://www.gnu.org/software/libtool}). Libtool is required by +Automake. +@end table + +The following external packages are required: + +@table @asis +@item PCRE +The Perl Compatible Reular Expression library (http://www.pcre.org). +@item BLAS +Basic Linear Algebra Subroutine library +(@url{http://www.netlib.org/blas}). Accelerated BLAS libraries such as +ATLAS (@url{http://math-atlas.sourceforge.net}) are recommeded for +better performance. +@item LAPACK +Linear Algebra Package (@url{http://www.netlib.org/lapack}). +@end table + +The following external package is optional but strongly recommended: + +@table @asis +@item GNU Readline +Command-line editing library (@url{www.gnu.org/s/readline}). +@end table + +If you wish to build Octave without GNU readline installed, you must use +the @code{--disable-readline} option when running the configure script. + +The following external software packages are optional but recommended: + +@table @asis +@item ARPACK +Library for the solution of large-scale eigenvalue problems +(@url{http://forge.scilab.org/index.php/p/arpack-ng}). ARPACK is +required to provide the functions @code{eigs} and @code{svds}. + +@item cURL +Library for transferring data with URL syntax +(@url{http://curl.haxx.se}). cURL is required to provide the +@code{urlread} and @code{urlwrite} functions and the @code{ftp} class. + +@item FFTW3 +Library for computing discrete Fourier transforms +(@url{http://www.fftw.org}). FFTW3 is used to provide better +performance for functions that compute discrete Fourier transforms +(@code{fft}, @code{ifft}, @code{fft2}, etc.) + +@item FLTK +Portable GUI toolkit (@url{http://www.fltk.org}). FLTK is currently +used to provide windows for Octave's OpenGL-based graphics functions. + +@item fontconfig +Library for configuring and customizing font access +(@url{http://www.freedesktop.org/wiki/Software/fontconfig}). Fontconfig +is used to manage fonts for Octave's OpenGL-based graphics functions. + +@item FreeType +Portable font engine (@url{http://www.freetype.org}). FreeType is used +to peform font rendering Octave's OpenGL-based graphics functions. + +@item GLPK +GNU Linear Programming Kit (@url{http://www.gnu.org/software/glpk}). +GPLK is required for the function @code{glpk}. + +@item gnuplot +Interactive graphics program (@url{http://www.gnuplot.info}). gnuplot +is currently the default graphics renderer for Octave. + +@item GraphicsMagick++ +Image processing library (@url{http://www.graphicsmagick.org}). +GraphicsMagick++ is used to provide the @code{imread} and @code{imwrite} +functions. + +@item HDF5 +Library for manipulating portable data files +(@url{http://www.hdfgroup.org/HDF5}). HDF5 is required for Octave's +@code{save} and @code{load} commands to write and read HDF data files. + +@item OpenGL +API for portable 2D and 3D graphics (@url{http://www.opengl.org}). An +OpenGL implementation is required to provide Octave's OpenGL-based +graphics functions. Octave's OpenGL-based graphics functions usually +outperform the gnuplot-based graphics functions because plot data can be +rendered directly instead of sending data and commands to gnuplot for +interpretation and rendering. + +@item Qhull +Computational geometry library (@url{http://www.qhull.org}). Qhull is +required to provide the functions @code{convhull}, @code{convhulln}, +@code{delaunay}, @code{delaunay3}, @code{delaunayn}, @code{voronoi}, and +@code{voronoin}. + +@item QRUPDATE +QR factorization updating library +(@url{http://sourceforge.net/projects/qrupdate}). QRUPDATE is used to +provide improved performance for the functions @code{qrdelete}, +@code{qrinsert}, @code{qrshift}, and @code{qrupdate}. + +@item SuiteSparse +Sparse matrix factorization library +(@url{http://www.cise.ufl.edu/research/sparse/SuiteSparse}). +SuiteSparse is required to provide sparse matrix factorizations and +solution of linear equations for sparse systems. + +@item zlib +Data compression library (@url{http://zlib.net}). The zlib library is +required for Octave's @code{load} and @code{save} commands to handle +compressed data, including @sc{Matlab} v5 MAT files. +@end table + +@node Running Configure and Make +@section Running Configure and Make @itemize @bullet @item @@ -314,13 +495,8 @@ @end table @end itemize -@menu -* Compiling Octave with 64-bit Indexing:: -* Installation Problems:: -@end menu - @node Compiling Octave with 64-bit Indexing -@appendixsec Compiling Octave with 64-bit Indexing +@section Compiling Octave with 64-bit Indexing Note: the following only applies to systems that have 64-bit pointers. Configuring Octave with @option{--enable-64} cannot magically make a @@ -585,7 +761,7 @@ @end itemize @node Installation Problems -@appendixsec Installation Problems +@section Installation Problems This section contains a list of problems (and some apparent problems that don't really mean anything is wrong) that may show up during
--- a/doc/interpreter/octave.texi Mon Jan 02 15:19:45 2012 -0500 +++ b/doc/interpreter/octave.texi Fri Jan 06 12:43:48 2012 -0500 @@ -860,6 +860,8 @@ Contributing Guidelines * How to Contribute:: +* Building the Development Sources:: +* Basics of Generating a Changeset:: * General Guidelines:: * Octave Sources (m-files):: * C++ Sources:: @@ -880,6 +882,9 @@ Installation +* Build Dependencies:: +* Running Configure and Make:: +* Compiling Octave with 64-bit Indexing:: * Installation Problems:: Emacs Octave Support
--- a/etc/README.Cygwin Mon Jan 02 15:19:45 2012 -0500 +++ b/etc/README.Cygwin Fri Jan 06 12:43:48 2012 -0500 @@ -7,17 +7,19 @@ This is a known problem with a long history and it is STRONGLY encouraged to use gcc-4.3.2-1 or later. -Current binary versions are built with gcc-4.3.4-3 while -binary version 3.0.2-2 was built with gcc-4.3.2-1. +Current binary versions are built with gcc-4.5.3-3. + -The latest development Octave development sources (octave-3.3.54+) +------- SUGGESTED CONFIGURATION --------------------------- + +The latest development Octave development sources (octave-3.5.91+) are built with: configure --enable-shared \ --enable-float-truncate \ CC=gcc-4 F77=gfortran-4 CXX=g++-4 CPP=cpp-4 lt_cv_deplibs_check_method=pass_all \ - LDFLAGS=-no-undefined + LDFLAGS=-Wl,-no-undefined "--enable-float-truncate" is needed for the following bug: http://thread.gmane.org/gmane.comp.gnu.octave.bugs/12361/focus=12404 @@ -29,6 +31,42 @@ incorrect libtool detection of system capabilities and to allow shared libs building. +"LDFLAGS=-Wl,-no-undefined" is better than previous +"LDFLAGS=-no-undefined" as gcc-4 is now complaining about +unknown command and the "undefined" is for the linker. + +The additional patch used for 3.4.3-3 package can also be +needed for 3.6.x (see below). + +------- SUGGESTION FOR FORK ISSUE -------------------------- + +The build process can fails in building images for documentation +due to fork issue of the octave dll just built. In such case +I suggest to rebase the built dll's with: + +$ find build_tree -name "*.dll" > rebase_list + +and after closing all cygwin process, from a dash shell + +$ rebaseall -s 'dll|so|oct' -T /full_path/rebase_list + +After rebasing the "make" should be able to complete the +creation of the images and the documentation. + +------------------------------------------------------ + +Octave-3.4.3-3 package was built using: + +configure --libexecdir=/usr/lib \ + --enable-shared \ + --enable-float-truncate \ + F77=gfortran-4 \ + lt_cv_deplibs_check_method=pass_all \ + LDFLAGS=-no-undefined + +plus and additional patch to solve a specific cygwin +fltk print issue, see: +https://savannah.gnu.org/bugs/?31641 Octave-3.2.4 was built using: @@ -38,14 +76,14 @@ CC=gcc-4 F77=gfortran-4 CXX=g++-4 CPP=cpp-4 CFLAGS="-Dtimezone=_timezone" - +------------------------------------------------------ Current Cygwin package maintainer for Octave: Marco Atzeri http://matzeri.altervista.org Marco Atzeri -marco_atzeri@yahoo.it +marco.atzeri@gmail.com Italy -Last updated: Mon Jan 3 18:53:41 WEST 2011 +Last updated: Tue Jan 3 14:40:58 WEST 2012
--- a/libcruft/Makefile.am Mon Jan 02 15:19:45 2012 -0500 +++ b/libcruft/Makefile.am Fri Jan 06 12:43:48 2012 -0500 @@ -69,7 +69,6 @@ EXTRA_DIST = include amos/module.mk -include arpack/module.mk include blas-xtra/module.mk include daspk/module.mk include dasrt/module.mk
--- a/libcruft/arpack/LICENSE Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,35 +0,0 @@ -BSD Software License - -Pertains to ARPACK and P_ARPACK - -Copyright (c) 1996-2008 Rice University. -Developed by D.C. Sorensen, R.B. Lehoucq, C. Yang, and K. Maschhoff. -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - -- Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - -- Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer listed - in this license in the documentation and/or other materials - provided with the distribution. - -- Neither the name of the copyright holders 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 COPYRIGHT HOLDERS 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 COPYRIGHT -OWNER 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.
--- a/libcruft/arpack/README Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,120 +0,0 @@ -1. You have successfully unbundled ARPACK and are now in the ARPACK - directory that was created for you. - -2. Recent bug fixes are included in patch.tar.gz and ppatch.tar.gz - If you have not retrieved these files, please do so and place them in - the directory right above the current directory. (They should - be in the same directory where arpack96.tar and parpack96.tar reside). - Use uncompress or gunzip to unzip the tar files, and use 'tar -xvf ' - to unbundle these patches. The source codes in these patches will - overwrite those contained in arpack96.tar and parpack96.tar. - -3. Upon executing the 'ls | more ' command you should see - - BLAS - DOCUMENTS - EXAMPLES - LAPACK - README - SRC - UTIL - Makefile - ARmake.inc - ARMAKES - PARPACK - - The following entries are directories: - - ARMAKES, BLAS, DOCUMENTS, EXAMPLES, LAPACK, SRC, UTIL, PARPACK - - The directory SRC contains the top level routines including - the highest level reverse communication interface routines - - ssaupd, dsaupd - symmetric single and double precision - snaupd, dnaupd - non-symmetric single and double precision - cnaupd, znaupd - complex non-symmetric single and double precision - - The headers of these routines contain full documentation of calling - sequence and usage. Additional information is in the DOCUMENTS directory. - - The directory PARPACK contains the Parallel ARPACK routines. - - -3. Example driver programs that illustrate all the computational modes, - data types and precisions may be found in the EXAMPLES directory. - Upon executing the 'ls EXAMPLES | more ' command you should see - - BAND - COMPLEX - NONSYM - README - SIMPLE - SVD - SYM - - Example programs for banded, complex, nonsymmetric, symmetric, - and singular value decomposition may be found in the directories - BAND, COMPLEX, NONSYM, SYM, SVD respectively. Look at the README - file for further information. To get started, get into the SIMPLE - directory to see example programs that illustrate the use of ARPACK in - the simplest modes of operation for the most commonly posed - standard eigenvalue problems. - - - Example programs for Parallel ARPACK may be found in the directory - PARPACK/EXAMPLES. Look at the README file for further information. - - The following instructions explain how to make the ARPACK library. - -4. Before you can compile anything, you must first edit and correct the file - ARmake.inc. Sample ARmake.inc's can be found in the ARMAKES directory. - If you plan on using Parallel ARPACK you will need to use those sample - files which contain either BLACS or MPI in their name. For example, - ARmake.MPI-$(PLAT) or ARmake.BLACS-$(PLAT). - Edit "ARmake.inc" and change the definition "home" to the root of the - source tree (Top level of ARPACK directory) - - The makefile is set up to build a self-contained library which includes - the needed BLAS 1/2/3 and LAPACK routines. If you already have the - BLAS and LAPACK libraries installed on your system you might want to - change the definition of DIRS as indicated in the ARmake.inc file. - - *** NOTE *** The LAPACK library on your system MUST be the public release. - The current release is version 2.0. If you are not certain if the public - release has been installed, we strongly recommend that you compile and link - to the subset of LAPACK included here. - - -5. You will also need to change the file "second.f" in the UTIL directory - to whatever is appropriate for timing on your system. The "second" routine - provided works on most workstations. If you are running on a Cray, - copy the file "second.f.CRAYT3D" to "second.f" to use the rtf system - function. - - -6. Do "make lib" in the current directory to build the standard library - "libarpack_$(PLAT).a" (serial code) - - To build the the parallel library, "parpack_$(COMMLIB)-$(PLAT).a", - type "make plib". When using the parallel routines you must link to - both the serial library and the parallel library. - - -7. Within DOCUMENTS directory there are three files - - ex-sym.doc - ex-nonsym.doc and - ex-complex.doc - - for templates on how to invoke the computational modes of ARPACK. - Also look in the README file for explanations concerning the - other documents. - - - Danny Sorensen at sorensen@caam.rice.edu - Richard Lehoucq at rblehou@sandia.gov - Chao Yang at cyang@lbl.gov - Kristi Maschhoff at kristyn@tera.com - - Good luck and enjoy. -
--- a/libcruft/arpack/docs/README Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,18 +0,0 @@ - - There are five documents within the DOCUMENT subdirectory. - In summary, - - ex-nonsym.doc, ex-sym.doc and ex-complex.doc - ------------- ---------- -------------- - Example Templates of how to invoke the different computational - modes offered by [D,S]NAUPD, [D,S]SAUPD and [C,Z]NAUPD. - - stat.doc - -------- - File that gets timing statistics for the different parts - of the Arnoldi update iteration codes within ARPACK. - - debug.doc - --------- - File that explains the different printing options of the - Arnoldi update iteration codes within ARPACK.
--- a/libcruft/arpack/docs/debug.doc Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,339 +0,0 @@ - ARPACK provides a means to trace the progress of the computation - as it proceeds. Various levels of output may be specified - from no output, level = 0, to voluminous, level = 3. - The following statements may be used within the calling program to - initiate and request this output. - - include 'debug.h' - ndigit = -3 - logfil = 6 - msgets = 0 - msaitr = 0 - msapps = 0 - msaupd = 1 - msaup2 = 0 - mseigt = 0 - mseupd = 0 - - The parameter "logfil" specifies the logical unit number of the output - file. The parameter "ndigit" specifies the number of decimal digits - and the width of the output lines. A positive value of "ndigit" - specifies that 132 columns are used during output and a negative - value specifies eighty columns are to be used. The values of the remaining - parameters indicate the output levels from the indicated routines. - - For the above example, "msaitr" indicates the level of output requested - for the subroutine ssaitr or dsaitr. The above configuration will - give a breakdown of the number of matrix vector products required, - the total number of iterations, the number of re-orthogonalization - steps and an estimate of the time spent in each routine and phase of the - computation. The following output is produced: - ---------------------------------------------------------------------- - ========================================== - = Symmetric implicit Arnoldi update code = - = Version Number: 2.1 = - = Version Date: 11/15/95 = - ========================================== - = Summary of timing statistics = - ========================================== - - - Total number update iterations = 8 - Total number of OP*x operations = 125 - Total number of B*x operations = 0 - Total number of reorthogonalization steps = 125 - Total number of iterative refinement steps = 0 - Total number of restart steps = 0 - Total time in user OP*x operation = 0.020002 - Total time in user B*x operation = 0.000000 - Total time in Arnoldi update routine = 0.210021 - Total time in ssaup2 routine = 0.190019 - Total time in basic Arnoldi iteration loop = 0.110011 - Total time in reorthogonalization phase = 0.070007 - Total time in (re)start vector generation = 0.000000 - Total time in trid eigenvalue subproblem = 0.040004 - Total time in getting the shifts = 0.000000 - Total time in applying the shifts = 0.040004 - Total time in convergence testing = 0.000000 - ---------------------------------------------------------------------- - - The user is encouraged to experiment with the other settings - once some familiarity has been gained with the routines. - - The include statement sets up the storage declarations that are - solely associated with this trace debugging feature. "debug.h" - has the following structure: - ---------------------------------------------------------------------- -c -c\SCCS Information: @(#) -c FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 -c -c %---------------------------------% -c | See debug.doc for documentation | -c %---------------------------------% - integer logfil, ndigit, mgetv0, - & msaupd, msaup2, msaitr, mseigt, msapps, msgets, mseupd, - & mnaupd, mnaup2, mnaitr, mneigh, mnapps, mngets, mneupd, - & mcaupd, mcaup2, mcaitr, mceigh, mcapps, mcgets, mceupd - common /debug/ - & logfil, ndigit, mgetv0, - & msaupd, msaup2, msaitr, mseigt, msapps, msgets, mseupd, - & mnaupd, mnaup2, mnaitr, mneigh, mnapps, mngets, mneupd, - & mcaupd, mcaup2, mcaitr, mceigh, mcapps, mcgets, mceupd ---------------------------------------------------------------------- - - - The parameters "msaupd, msaup2, msaitr, mseigt, msapps, msgets, mseupd" - are for the symmetric codes, while - "mnaupd, mnaup2, mnaitr, mneigh, mnapps, mngets, mneupd" are for the - nonsymmetric codes and, finally, - "mcaupd, mcaup2, mcaitr, mceigh, mcapps, mcgets, mceupd" are for the complex - arithmetic codes. A comprehensive break down of each parameter is given - below. - - ========================================================== - === Common to symmetric, nonsymmetric and complex code === - ========================================================== - - - logfil: unit number where the logfile (debug) is written - - ndigit: number of digits used in the debug output - ndigit < 0: printing is done with 72 columns. - ndigit > 0: printing is done with 132 columns. - - mgetv0 > 0: print residual vector generated. - - ====================================== - === Specific to the symmetric code === - ====================================== - - msaupd > 0: *Print the number of iterations taken, - number of "converged" eigenvalues, - final Ritz values and corresponding Ritz estimates. - *Print various timing statistics. - - msaup2 > 0: *Print major iteration number, - number of "converged" Ritz values on exit, - B-norm of the residual vector of length NCV factorization, - B-norm of the residual vector of length NEV factorization, - residual norm before exit, - Ritz values and corresponding Ritz estimates before exit. - msaup2 > 1: print number of unreduced submatrices, - Ritz values and corresponding Ritz estimates of the current - T matrix, actual values for NEV and NP, - wanted Ritz values and corresponding Ritz estimates, - shifts selected. - msaup2 > 2: print "unwanted" Ritz values and corresponding Ritz - estimates, order NCV matrix T (diagonal and off-diagonal), - unwanted Ritz values and error bounds. - - msaitr > 0: print iteration number, residual norm, restart info - print if an off diagonal element of T became negative. - msaitr > 1: print the final matrix T. - msaitr > 2: print Arnoldi vector no. generate at iteration j, - b-norm of residual vector at each iteration, - print rnorm and rnorm1 for iterative refinement, - print wnorm and rnorm used for Re-orthogonalization, - V^T * B * (resid/B-norm(resid)), - print the results of whether the current residual vector is - orthogonal to the current Lanczos basis. - msaitr > 3: print the matrix T at each iteration. - print the residual vector and arnoldi vectors. - - mseigt > 0: print the current matrix T. - - msgets > 0: print NEV and NP, - eigenvalues of and corresponding Ritz estimates of the - current T matrix. - - msapps > 0: print information about deflation at row/column no. - msapps > 1: print initial matrix T - print sigmak, betak and matrix T after all shifts - msapps > 2: print the matrix T after the application of each shift. - msapps > 3: updated residual for next iteration. - - mseupd > 1: print eigenvalues of the final T matrix, - the last row of the eigenvector matrix for T, - if reordered, reordered last row of the eigenvector matrix, - reordered NCV Ritz values of the final T matrix, - if type = 'REGULAR', untransformed "converged" Ritz values - and corresponding Ritz estimates, - NCV Ritz values of the final T matrix, - last row of the eigenvector matrix for T, - if reordered, reordered last row of the eigenvector matrix, - reordered NCV Ritz values of the final T. - - mseupd > 2: print the matrix T. - - ========================================= - === Specific to the nonsymmetric code === - ========================================= - - mnaupd > 0: *Print the number of iterations taken, - number of "converged" eigenvalues, - real and imaginary parts of the converged Ritz values - and their corresponding Ritz estimates, - *Print various timing statistics. - - mnaup2 > 0: *Print major iteration number. - *Print the number of "converged" Ritz values on exit, - and the real and imaginary parts of the "converged" Ritz - values and corresponding Ritz estimates. - mnaup2 > 1: *Print the length of the Arnoldi Factorization, - and the B-norm of its residual vector. - *Print NEV and NP, real and imaginary parts of the "wanted" - Ritz values and associated Ritz estimates at each - iteration. - *Print the B-norm of the residual of the compressed - factorization and the compressed upper Hessenberg matrix H. - mnaup2 > 2: *Print the real and imaginary parts of all the Ritz values - and associated Ritz estimates, NEV, NP, NUMCNV, NCONV. - *Print the real and imaginary parts of the shifts. If the - exact shift strategy is used, print the associated Ritz - estimates of the shifts. - *Print the real and imaginary parts of the Ritz values - and the corresponding Ritz estimates obtained from _neigh. - - mnaitr > 0: *Print if a restart is needed. - mnaitr > 1: *Print the number of Arnoldi vector being generated and - the B-norm of the current residual. - mnaitr > 2: *Print j-th column of the Hessenberg matrix H. - *Print reorthogonalization and iterative refinement information, - *Print the final upper Hessenberg matrix of order K+NEV. - mnaitr > 3: *Print V^T*B*resid/(B-norm(resid)). - mnaitr > 4: *Print current upper Hessenberg matrix. - mnaitr > 5: *Print updated arnoldi vectors and the residual vector. - - mneigh > 1: *Print the last row of the Schur matrix for H, and - the last row of the eigenvector matrix for H. - mneigh > 2: *Print the entering upper Hessenberg matrix. - *Print the real and imaginary part of eigenvalues - of the current Hessenberg matrix, and associated - Ritz estimates. - - mngets > 0: *Print the real and imaginary parts of the Ritz values - of the Hessenberg matrix and their the corresponding - error bounds, KEV, NP. - - mnapps > 0: *Print information about where deflation occured. - mnapps > 1: *Print sigmak, betak, order of the final Hessenberg matrix, - and the final compressed upper Hessenberg matrix. - mnapps > 2: *Print implicit application of shift number, real and imaginary - part of the shift. - *Print the indices of the submatrix that the shift is applied. - mnapps > 3: *Print the matrix H before and after the application of - each shift, updated residual for next iteration. - mnapps > 4: *Print the accumulated orthogonal Hessenberg matrix Q, - updated matrix of Arnoldi vectors. - - mneupd > 0: *Print the number of converged Ritz values, B-norm of the - residual, all NCV Ritz values and error bounds. - mneupd > 1: *Print the final upper Hessenberg matrix computed by _naupd. - *If Ritz vectors are requested, print real and imaginary parts - of the eigenvalues and the last row of the Schur vectors as - computed by _neupd. - mneupd > 2: *If Ritz vectors are requested, print the threshold eigenvalue - used for re-ordering. - *If Ritz vectors are requested, print the number of eigenvalues - to reorder and the number of converged Ritz values. - *If Ritz vectors are requested, print the upper quasi-matrix - computed by _neupd. - *If Ritz vectors are requested, print the real and imaginary - part of the Ritz values. - *If Ritz vectors are requested, print the last row of the - eigenvector matrix. - *Print the NCV Ritz estimates in the original system. - mneupd > 3: *Print the integer array of pointers. - *If Ritz vectors are requested, print the eigenvector matrix. - *If Ritz vectors are requested, print the reordered upper - quasi-triangular matrix. - mneupd > 4: *If Ritz vectors are requested, print the Q matrix of the QR - factorization of the matrix representing the wanted invariant - subspace. - *If Ritz vectors are requested, print the Schur vectors. - *If Ritz vectors are requested, print the reordered Schur vectors. - - - ==================================== - === Specific to the complex code === - ==================================== - - mcaupd > 0: *Print the number of iterations taken, - number of "converged" eigenvalues, the converged Ritz values - and their corresponding Ritz estimates, - *Print various timing statistics. - - mcaup2 > 0: *Print major iteration number. - *Print the number of "converged" Ritz values on exit, and the - "converged" Ritz values and corresponding Ritz estimates. - mcaup2 > 1: *Print the length of the Arnoldi Factorization, - and the B-norm of its residual vector. - *Print NEV and NP, the "wanted" Ritz values and associated Ritz - estimates at each iteration. - *Print the B-norm of the residual of the compressed - factorization and the compressed upper Hessenberg matrix H. - mcaup2 > 2: *Print the all the Ritz values and associated Ritz estimates, - NEV, NP, NUMCNV, NCONV. - *Print the shifts. If the exact shift strategy is used, print the - associated Ritz estimates of the shifts. - *Print the Ritz values and the corresponding Ritz estimates obtained - from _neigh. - - mcaitr > 0: *Print if a restart is needed. - mcaitr > 1: *Print the number of Arnoldi vector being generated and - the B-norm of the current residual. - mcaitr > 2: *Print j-th column of the Hessenberg matrix H. - *Print reorthogonalization and iterative refinement information, - *Print the final upper Hessenberg matrix of order K+NEV. - mcaitr > 3: *Print V^T*B*resid/(B-norm(resid)). - mcaitr > 4: *Print current upper Hessenberg matrix. - mcaitr > 5: *Print updated Arnoldi vectors and the residual vector. - - mceigh > 1: *Print the last row of the Schur matrix for H, and - the last row of the eigenvector matrix for H. - mceigh > 2: *Print the entering upper Hessenberg matrix. - *Print the eigenvalues of the current Hessenberg matrix, and - associated Ritz estimates. - - mcgets > 0: *Print the real and imaginary parts of the Ritz values - of the Hessenberg matrix and their the corresponding - error bounds, KEV, NP. - - mcapps > 0: *Print information about where deflation occured. - mcapps > 1: *Print sigmak, betak, order of the final Hessenberg matrix, - and the final compressed upper Hessenberg matrix. - mcapps > 2: *Print implicit application of shift number, the shift. - *Print the indices of the submatrix that the shift is applied. - mcapps > 3: *Print the matrix H before and after the application of - each shift, updated residual for next iteration. - mcapps > 4: *Print the accumulated unitary Hessenberg matrix Q, and the - updated matrix of Arnoldi vectors. - - mceupd > 0: *Print the number of converged Ritz values, B-norm of the - residual, all NCV Ritz values and error bounds. - mceupd > 1: *Print the final upper Hessenberg matrix computed by _naupd. - *If Ritz vectors are requested, print the eigenvalues and the - last row of the Schur vectors as computed by _neupd. - mceupd > 2: *If Ritz vectors are requested, print the threshold eigenvalue - used for re-ordering. - *If Ritz vectors are requested, print the number of eigenvalues - to reorder and the number of converged Ritz values. - *If Ritz vectors are requested, print the upper quasi-matrix - computed by _neupd. - *If Ritz vectors are requested, print the Ritz values. - *If Ritz vectors are requested, print the last row of the - eigenvector matrix. - *Print the NCV Ritz estimates in the original system. - mceupd > 3: *Print the integer array of pointers. - *If Ritz vectors are requested, print the eigenvector matrix. - mceupd > 4: *If Ritz vectors are requested, print the Q matrix of the QR - factorization of the matrix representing the wanted invariant - subspace. - *If Ritz vectors are requested, print the Schur vectors. - - -
--- a/libcruft/arpack/docs/ex-complex.doc Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,152 +0,0 @@ -c----------------------------------------------------------------------- -c -c\Example-1 -c ... Suppose want to solve A*x = lambda*x in regular mode -c ... so OP = A and B = I. -c ... Assume "call matvecA(n,x,y)" computes y = A*x -c ... Assume exact shifts are used -c ... -c ido = 0 -c iparam(7) = 1 -c -c %------------------------------------% -c | Beginning of reverse communication | -c %------------------------------------% -c 10 continue -c call _naupd ( ido, 'I', n, which, nev, tol, resid, ncv, v, ldv, -c & iparam, ipntr, workd, workl, lworkl, rwork, info ) -c if (ido .eq. -1 .or. ido .eq. 1) then -c call matvecA (n, workd(ipntr(1)), workd(ipntr(2))) -c go to 10 -c end if -c %------------------------------% -c | End of Reverse communication | -c %------------------------------% -c -c ... call _neupd to postprocess -c ... want the Ritz vectors set rvec = .true. else rvec = .false. -c call _neupd ( rvec, 'All', select, d, d(1,2), v, ldv, -c & sigmar, sigmai, workev, bmat, n, which, nev, tol, -c & resid, ncv, v, ldv, iparam, ipntr, workd, workl, -c & lworkl, rwork, info ) -c stop -c end -c -c\Example-2 -c ... Suppose want to solve A*x = lambda*x in shift-invert mode -c ... so OP = inv[A - sigma*I] and B = I -c ... Assume "call solve(n,rhs,x)" solves [A - sigma*I]*x = rhs -c ... Assume exact shifts are used -c ... -c ido = 0 -c iaparam(7) = 3 -c -c %------------------------------------% -c | Beginning of reverse communication | -c %------------------------------------% -c 10 continue -c call _naupd ( ido, 'I', n, which, nev, tol, resid, ncv, v, ldv, -c & iparam, ipntr, workd, workl, lworkl, rwork, info ) -c if (ido .eq. -1 .or. ido .eq. 1) then -c call solve (n, workd(ipntr(1)), workd(ipntr(2))) -c go to 10 -c end if -c %------------------------------% -c | End of Reverse communication | -c %------------------------------% -c -c ... call _neupd to postprocess -c ... want the Ritz vectors set rvec = .true. else rvec = .false. -c call _neupd ( rvec, 'All', select, d, d(1,2), v, ldv, -c & sigmar, sigmai, workev, bmat, n, which, nev, tol, -c & resid, ncv, v, ldv, iparam, ipntr, workd, workl, -c & lworkl, rwork, info ) -c stop -c end -c -c\Example-3 -c ... Suppose want to solve A*x = lambda*M*x in regular mode -c ... so OP = inv[M]*A and B = M. -c ... Assume "call matvecM(n,x,y)" computes y = M*x -c ... Assume "call matvecA(n,x,y)" computes y = A*x -c ... Assume "call solveM(n,rhs,x)" solves M*x = rhs -c ... Assume user will supplied shifts -c ... -c ido = 0 -c iparam(7) = 2 -c -c %------------------------------------% -c | Beginning of reverse communication | -c %------------------------------------% -c 10 continue -c call _naupd ( ido, 'G', n, which, nev, tol, resid, ncv, v, ldv, -c & iparam, ipntr, workd, workl, lworkl, rwork, info ) -c if (ido .eq. -1 .or. ido .eq. 1) then -c call matvecA (n, workd(ipntr(1)), temp_array) -c call solveM (n, temp_array, workd(ipntr(2))) -c go to 10 -c else if (ido .eq. 2) then -c call matvecM (n, workd(ipntr(1)), workd(ipntr(2))) -c go to 10 -c -c ... delete this last conditional if want to use exact shifts -c else if (ido .eq. 3) then -c ... compute shifts and put in workl starting from the position -c ... pointed by ipntr(14). -c np = iparam(8) -c call scopy (np, shifts, 1, workl(ipntr(14), 1) -c go to 10 -c end if -c %------------------------------% -c | End of Reverse communication | -c %------------------------------% -c -c ... call _neupd to postprocess -c ... want the Ritz vectors set rvec = .true. else rvec = .false. -c call _neupd ( rvec, 'All', select, d, d(1,2), v, ldv, -c & sigmar, sigmai, workev, bmat, n, which, nev, tol, -c & resid, ncv, v, ldv, iparam, ipntr, workd, workl, -c & lworkl, rwork, info ) -c stop -c end -c -c\Example-4 -c ... Suppose want to solve A*x = lambda*M*x in shift-invert mode -c ... so OP = inv[A - sigma*M]*M and B = M -c ... Assume "call matvecM(n,x,y)" computes y = M*x -c ... Assume "call solve(n,rhs,x)" solves [A - sigma*M]*x = rhs -c ... Assume exact shifts are used -c ... -c ido = 0 -c iparam(7) = 3 -c -c %------------------------------------% -c | Beginning of reverse communication | -c %------------------------------------% -c 10 continue -c call _naupd ( ido, 'G', n, which, nev, tol, resid, ncv, v, ldv, -c & iparam, ipntr, workd, workl, lworkl, rwork, info ) -c if (ido .eq. -1) then -c call matvecM (n, workd(ipntr(1)), temp_array) -c call solve (n, temp_array, workd(ipntr(2))) -c go to 10 -c else if (ido .eq. 1) then -c call solve (n, workd(ipntr(3)), workd(ipntr(2))) -c go to 10 -c else if (ido .eq. 2) then -c call matvecM (n, workd(ipntr(1)), workd(ipntr(2))) -c go to 10 -c end if -c %------------------------------% -c | End of Reverse communication | -c %------------------------------% -c -c ... call _neupd to postprocess -c ... want the Ritz vectors set rvec = .true. else rvec = .false. -c call _neupd ( rvec, 'All', select, d, d(1,2), v, ldv, -c & sigmar, sigmai, workev, bmat, n, which, nev, tol, -c & resid, ncv, v, ldv, iparam, ipntr, workd, workl, -c & lworkl, rwork, info ) -c stop -c end -c\EndDoc
--- a/libcruft/arpack/docs/ex-nonsym.doc Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,256 +0,0 @@ -c----------------------------------------------------------------------- -c -c\Example-1 -c ... Suppose want to solve A*x = lambda*x in regular mode -c ... so OP = A and B = I. -c ... Assume "call matvecA(n,x,y)" computes y = A*x -c ... Assume exact shifts are used -c ... -c ido = 0 -c iparam(7) = 1 -c -c %------------------------------------% -c | Beginning of reverse communication | -c %------------------------------------% -c 10 continue -c call _naupd ( ido, 'I', n, which, nev, tol, resid, ncv, v, ldv, -c & iparam, ipntr, workd, workl, lworkl, info ) -c if (ido .eq. -1 .or. ido .eq. 1) then -c call matvecA (n, workd(ipntr(1)), workd(ipntr(2))) -c go to 10 -c end if -c %------------------------------% -c | End of Reverse communication | -c %------------------------------% -c -c ... call _neupd to postprocess -c ... want the Ritz vectors set rvec = .true. else rvec = .false. -c call _neupd ( rvec, 'All', select, d, d(1,2), v, ldv, -c & sigmar, sigmai, workev, bmat, n, which, nev, tol, -c & resid, ncv, v, ldv, iparam, ipntr, workd, workl, -c & lworkl, info ) -c stop -c end -c -c\Example-2 -c ... Suppose want to solve A*x = lambda*x in shift-invert mode -c ... so OP = inv[A - sigma*I] and B = I, sigma has zero -c ... imaginary part -c ... Assume "call solve(n,rhs,x)" solves [A - sigma*I]*x = rhs -c ... Assume exact shifts are used -c ... -c ido = 0 -c iaparam(7) = 3 -c -c %------------------------------------% -c | Beginning of reverse communication | -c %------------------------------------% -c 10 continue -c call _naupd ( ido, 'I', n, which, nev, tol, resid, ncv, v, ldv, -c & iparam, ipntr, workd, workl, lworkl, info ) -c if (ido .eq. -1 .or. ido .eq. 1) then -c call solve (n, workd(ipntr(1)), workd(ipntr(2))) -c go to 10 -c end if -c %------------------------------% -c | End of Reverse communication | -c %------------------------------% -c -c ... call _neupd to postprocess -c ... want the Ritz vectors set rvec = .true. else rvec = .false. -c call _neupd ( rvec, 'All', select, d, d(1,2), v, ldv, -c & sigmar, sigmai, workev, bmat, n, which, nev, tol, -c & resid, ncv, v, ldv, iparam, ipntr, workd, workl, -c & lworkl, info ) -c stop -c end -c -c\Example-3 -c ... Suppose want to solve A*x = lambda*M*x in regular mode -c ... so OP = inv[M]*A and B = M. -c ... Assume "call matvecM(n,x,y)" computes y = M*x -c ... Assume "call matvecA(n,x,y)" computes y = A*x -c ... Assume "call solveM(n,rhs,x)" solves M*x = rhs -c ... Assume user will supplied shifts -c ... -c ido = 0 -c iparam(7) = 2 -c -c %------------------------------------% -c | Beginning of reverse communication | -c %------------------------------------% -c 10 continue -c call _naupd ( ido, 'G', n, which, nev, tol, resid, ncv, v, ldv, -c & iparam, ipntr, workd, workl, lworkl, info ) -c if (ido .eq. -1 .or. ido .eq. 1) then -c call matvecA (n, workd(ipntr(1)), temp_array) -c call solveM (n, temp_array, workd(ipntr(2))) -c go to 10 -c else if (ido .eq. 2) then -c call matvecM (n, workd(ipntr(1)), workd(ipntr(2))) -c go to 10 -c -c ... delete this last conditional if want to use exact shifts -c else if (ido .eq. 3) then -c ... compute shifts and put in workl starting from the position -c ... pointed by ipntr(14). -c np = iparam(8) -c call scopy (np, shifts, 1, workl(ipntr(14), 1) -c go to 10 -c end if -c %------------------------------% -c | End of Reverse communication | -c %------------------------------% -c -c ... call _neupd to postprocess -c ... want the Ritz vectors set rvec = .true. else rvec = .false. -c call _neupd ( rvec, 'All', select, d, d(1,2), v, ldv, -c & sigmar, sigmai, workev, bmat, n, which, nev, tol, -c & resid, ncv, v, ldv, iparam, ipntr, workd, workl, -c & lworkl, info ) -c stop -c end -c -c\Example-4 -c ... Suppose want to solve A*x = lambda*M*x in shift-invert mode -c ... so OP = inv[A - sigma*M]*M and B = M, sigma has zero -c ... imaginary part -c ... Assume "call matvecM(n,x,y)" computes y = M*x -c ... Assume "call solve(n,rhs,x)" solves [A - sigma*M]*x = rhs -c ... Assume exact shifts are used -c ... -c ido = 0 -c iparam(7) = 3 -c -c %------------------------------------% -c | Beginning of reverse communication | -c %------------------------------------% -c 10 continue -c call _naupd ( ido, 'G', n, which, nev, tol, resid, ncv, v, ldv, -c & iparam, ipntr, workd, workl, lworkl, info ) -c if (ido .eq. -1) then -c call matvecM (n, workd(ipntr(1)), temp_array) -c call solve (n, temp_array, workd(ipntr(2))) -c go to 10 -c else if (ido .eq. 1) then -c call solve (n, workd(ipntr(3)), workd(ipntr(2))) -c go to 10 -c else if (ido .eq. 2) then -c call matvecM (n, workd(ipntr(1)), workd(ipntr(2))) -c go to 10 -c end if -c %------------------------------% -c | End of Reverse communication | -c %------------------------------% -c -c ... call _neupd to postprocess -c ... want the Ritz vectors set rvec = .true. else rvec = .false. -c call _neupd ( rvec, 'All', select, d, d(1,2), v, ldv, -c & sigmar, sigmai, workev, bmat, n, which, nev, tol, -c & resid, ncv, v, ldv, iparam, ipntr, workd, workl, -c & lworkl, info ) -c stop -c end -c -c\Example-5 -c ... Suppose want to solve A*x = lambda*M*x in shift-invert mode -c ... So OP = Real_Part{inv[A-SIGMA*M]*M and B=M, sigma has -c ... nonzero imaginary part -c ... Assume "call matvecM(n,x,y)" computes y = M*x -c ... Assume "call solve(n,rhs,x)" solves [A - sigma*M]*x = rhs -c ... in complex arithmetic -c ... Assume exact shifts are used -c ... -c ido = 0 -c iparam(7) = 3 -c -c %------------------------------------% -c | Beginning of reverse communication | -c %------------------------------------% -c 10 continue -c call _naupd ( ido, 'G', n, which, nev, tol, resid, ncv, v, ldv, -c & iparam, ipntr, workd, workl, lworkl, info ) -c if (ido .eq. -1) then -c call matvecM (n, workd(ipntr(1)), temp_array) -c call solve(n, temp_array, complex_array) -c do i = 1, n -c workd(ipntr(2)+i-1) = real(complex_array(i)) -c end do -c go to 10 -c else if (ido .eq. 1) then -c call solve (n, workd(ipntr(3)), complex_array) -c do i = 1, n -c workd(ipntr(2)+i-1) = real(complex_array(i)) -c end do -c go to 10 -c else if (ido .eq. 2) then -c call matvecM (n, workd(ipntr(1)), workd(ipntr(2))) -c go to 10 -c end if -c %------------------------------% -c | End of Reverse communication | -c %------------------------------% -c -c ... call _neupd to postprocess. -c ... want the Ritz vectors set rvec = .true. else rvec = .false. -c call _neupd ( rvec, 'All', select, d, d(1,2), v, ldv, -c & sigmar, sigmai, workev, bmat, n, which, nev, tol, -c & resid, ncv, v, ldv, iparam, ipntr, workd, workl, -c & lworkl, info ) -c ... Use Rayleigh quotient to transform d(:,1) and d(:,2) -c to the approximation to the original problem. -c stop -c end -c -c\Example-6 -c ... Suppose want to solve A*x = lambda*M*x in shift-invert mode -c ... So OP = Imaginary_Part{inv[A-SIGMA*M]*M and B=M, sigma must -c ... have nonzero imaginary part -c ... Assume "call matvecM(n,x,y)" computes y = M*x -c ... Assume "call solve(n,rhs,x)" solves [A - sigma*M]*x = rhs -c ... in complex arithmetic -c ... Assume exact shifts are used -c ... -c ido = 0 -c iparam(7) = 3 -c -c %------------------------------------% -c | Beginning of reverse communication | -c %------------------------------------% -c 10 continue -c call _naupd ( ido, 'G', n, which, nev, tol, resid, ncv, v, ldv, -c & iparam, ipntr, workd, workl, lworkl, info ) -c if (ido .eq. -1) then -c call matvecM (n, workd(ipntr(1)), temp_array) -c call solve(n, temp_array, complex_array) -c do i = 1, n -c workd(ipntr(2)+i-1) = aimag(complex_array(i)) -c end do -c go to 10 -c else if (ido .eq. 1) then -c call solve (n, workd(ipntr(3)), complex_array) -c do i = 1, n -c workd(ipntr(2)+i-1) = aimag(complex_array(i)) -c end do -c go to 10 -c else if (ido .eq. 2) then -c call matvecM (n, workd(ipntr(1)), workd(ipntr(2))) -c go to 10 -c end if -c %------------------------------% -c | End of Reverse communication | -c %------------------------------% -c -c ... call _neupd to postprocess -c ... want the Ritz vectors set rvec = .true. else rvec = .false. -c call _neupd ( rvec, 'All', select, d, d(1,2), v, ldv, -c & sigmar, sigmai, workev, bmat, n, which, nev, tol, -c & resid, ncv, v, ldv, iparam, ipntr, workd, workl, -c & lworkl, info ) -c ... Use Rayleigh quotient to transform d(:,1) and d(:,2) -c to the Ritz approximation to the original problem. -c stop -c end -c -c\EndDoc -
--- a/libcruft/arpack/docs/ex-sym.doc Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,234 +0,0 @@ -c----------------------------------------------------------------------- -c -c\Example-1 -c ... Suppose want to solve A*x = lambda*x in regular mode -c ... so OP = A and B = I. -c ... Assume "call matvecA(n,x,y)" computes y = A*x -c ... Assume exact shifts are used -c ... -c ido = 0 -c iparam(7) = 1 -c -c %------------------------------------% -c | Beginning of reverse communication | -c %------------------------------------% -c 10 continue -c call _saupd ( ido, 'I', n, which, nev, tol, resid, ncv, v, ldv, iparam, -c & ipntr, workd, workl, lworkl, info ) -c if (ido .eq. -1 .or. ido .eq. 1) then -c call matvecA (n, workd(ipntr(1)), workd(ipntr(2))) -c go to 10 -c end if -c %------------------------------% -c | End of Reverse communication | -c %------------------------------% -c -c ... Call _seupd to postprocess -c ... want the Ritz vectors set rvec = .true. else rvec = .false. -c call _seupd ( rvec, 'All', select, d, z, ldz, sigma, bmat, -c & n, which, nev, tol, resid, ncv, v, ldv, iparam, -c & ipntr, workd, workl, lworkl, info ) -c -c stop -c end -c -c\Example-2 -c ... Suppose want to solve A*x = lambda*x in shift-invert mode -c ... so OP = inv[A - sigma*I] and B = I. -c ... Assume "call solve(n,rhs,x)" solves [A - sigma*I]*x = rhs -c ... Assume exact shifts are used -c ... -c ido = 0 -c iparam(7) = 3 -c -c %------------------------------------% -c | Beginning of reverse communication | -c %------------------------------------% -c 10 continue -c call _saupd ( ido, 'I', n, which, nev, tol, resid, ncv, v, ldv, iparam, -c & ipntr, workd, workl, lworkl, info ) -c if (ido .eq. -1 .or. ido .eq. 1) then -c call solve (n, workd(ipntr(1)), workd(ipntr(2))) -c go to 10 -c end if -c %------------------------------% -c | End of Reverse communication | -c %------------------------------% -c -c ... Call _seupd to postprocess -c ... want the Ritz vectors set rvec = .true. else rvec = .false. -c call _seupd ( rvec, 'All', select, d, z, ldz, sigma, bmat, -c & n, which, nev, tol, resid, ncv, v, ldv, iparam, -c & ipntr, workd, workl, lworkl, info ) -c -c\Example-3 -c ... Suppose want to solve A*x = lambda*M*x in regular mode -c ... so OP = inv[M]*A and B = M. -c ... Assume "call matvecM(n,x,y)" computes y = M*x -c ... Assume "call matvecA(n,x,y)" computes y = A*x -c ... Assume "call solveM(n,rhs,x)" solves M*x = rhs -c ... Assume user will supplied shifts -c ... -c ido = 0 -c iparam(7) = 2 -c -c %------------------------------------% -c | Beginning of reverse communication | -c %------------------------------------% -c 10 continue -c call _saupd ( ido, 'G', n, which, nev, tol, resid, ncv, v, ldv, iparam, -c & ipntr, workd, workl, lworkl, info ) -c if (ido .eq. -1 .or. ido .eq. 1) then -c call matvecA (n, workd(ipntr(1)), temp_array) -c call _scopy (n, temp_array, 1, workd(ipntr(1)), 1) -c call solveM (n, temp_array, workd(ipntr(2))) -c go to 10 -c else if (ido .eq. 2) then -c call matvecM (n, workd(ipntr(1)), workd(ipntr(2))) -c go to 10 -c -c ... delete this last conditional if want to use exact shifts -c else if (ido .eq. 3) then -c ... compute shifts and put in the first np locations of work -c np = iparam(8) -c call _copy (np, shifts, 1, workl(ipntr(11), 1) -c go to 10 -c end if -c %------------------------------% -c | End of Reverse communication | -c %------------------------------% -c -c ... call _seupd to postprocess -c ... want the Ritz vectors set rvec = .true. else rvec = .false. -c call _seupd ( rvec, 'All', select, d, z, ldz, sigma, bmat, -c & n, which, nev, tol, resid, ncv, v, ldv, iparam, -c & ipntr, workd, workl, lworkl, info ) -c stop -c end -c -c\Example-4 -c ... Suppose want to solve A*x = lambda*M*x in shift-invert mode -c ... so OP = (inv[A - sigma*M])*M and B = M. -c ... Assume "call matvecM(n,x,y)" computes y = M*x -c ... Assume "call solve(n,rhs,x)" solves [A - sigma*M]*x = rhs -c ... Assume exact shifts are used -c ... -c ido = 0 -c iparam(7) = 3 -c -c %------------------------------------% -c | Beginning of reverse communication | -c %------------------------------------% -c 10 continue -c call _saupd ( ido, 'G', n, which, nev, tol, resid, ncv, v, ldv, iparam, -c & ipntr, workd, workl, lworkl, info ) -c if (ido .eq. -1) then -c call matvecM (n, workd(ipntr(1)), temp_array) -c call solve (n, temp_array, workd(ipntr(2))) -c go to 10 -c else if (ido .eq. 1) then -c call solve (n, workd(ipntr(3)), workd(ipntr(2))) -c go to 10 -c else if (ido .eq. 2) then -c call matvecM (n, workd(ipntr(1)), workd(ipntr(2))) -c go to 10 -c end if -c %------------------------------% -c | End of Reverse communication | -c %------------------------------% -c -c ... call _seupd to postprocess -c ... want the Ritz vectors set rvec = .true. else rvec = .false. -c call _seupd ( rvec, 'All', select, d, z, ldz, sigma, bmat, -c & n, which, nev, tol, resid, ncv, v, ldv, iparam, -c & ipntr, workd, workl, lworkl, info ) -c -c stop -c end -c -c\Example-5 -c ... Suppose want to solve K*x = lambda*KG*x in Buckling mode -c ... so OP = (inv[K - sigma*KG])*K and B = K. -c ... Assume "call matvecM(n,x,y)" computes y = KG*x -c ... Assume "call matvecA(n,x,y)" computes y = K*x -c ... Assume "call solve(n,rhs,x)" solves [K - sigma*KG]*x = rhs -c ... Assume exact shifts are used -c -c ido = 0 -c iparam(7) = 4 -c -c %------------------------------------% -c | Beginning of reverse communication | -c %------------------------------------% -c 10 continue -c call _saupd ( ido, 'G', n, which, nev, tol, resid, ncv, v, ldv, iparam, -c & ipntr, workd, workl, lworkl, info ) -c if (ido .eq. -1) then -c call matvecA (n, workd(ipntr(1)), temp_array) -c solve (n, temp_array, workd(ipntr(2))) -c go to 10 -c else if (ido .eq. 1) then -c call solve (n, workd(ipntr(3)), workd(ipntr(2))) -c go to 10 -c else if (ido .eq. 2) then -c call matvecA (n, workd(ipntr(1)), workd(ipntr(2))) -c go to 10 -c end if -c %------------------------------% -c | End of Reverse communication | -c %------------------------------% -c -c ... call _seupd to postprocess -c ... want the Ritz vectors set rvec = .true. else rvec = .false. -c call _seupd ( rvec, 'All', select, d, z, ldz, sigma, bmat, -c & n, which, nev, tol, resid, ncv, v, ldv, iparam, -c & ipntr, workd, workl, lworkl, info ) -c stop -c end -c -c\Example-6 -c ... Suppose want to solve A*x = lambda*M*x in Cayley mode -c ... so OP = inv[A - sigma*M]*[A + sigma*M] and B = M. -c ... Assume "call matvecM(n,x,y)" computes y = M*x -c ... Assume "call matvecA(n,x,y)" computes y = A*x -c ... Assume "call solve(n,rhs,x)" solves [A - sigma*M]*x = rhs -c ... Assume exact shifts are used -c ... -c ido = 0 -c iparam(7) = 5 -c -c %------------------------------------% -c | Beginning of reverse communication | -c %------------------------------------% -c 10 continue -c call _saupd ( ido, 'G', n, which, nev, tol, resid, ncv, v, ldv, iparam, -c & ipntr, workd, workl, lworkl, info ) -c if (ido .eq. -1) then -c call matvecM (n, workd(ipntr(1)), workd(ipntr(2))) -c call matvecA (n, workd(ipntr(1)), temp_array) -c call _axpy (n, sigma, workd(inptr(2)), 1, temp_array, 1) -c call solve (n, temp_array, workd(ipntr(2))) -c go to 10 -c else if (ido .eq. 1) then -c call matvecA (n, workd(ipntr(1)), workd(ipntr(2))) -c call _axpy (n, sigma, workd(inptr(3)), 1, workd(ipntr(2)), 1) -c call _copy (n, workd(inptr(2)), 1, workd(ipntr(3)), 1) -c call solve (n, workd(ipntr(3)), workd(ipntr(2))) -c go to 10 -c else if (ido .eq. 2) then -c call matvecM (n, workd(ipntr(1)), workd(ipntr(2))) -c go to 10 -c end if -c %------------------------------% -c | End of Reverse communication | -c %------------------------------% -c -c ... call _seupd to postprocess -c ... want the Ritz vectors set rvec = .true. else rvec = .false. -c call _seupd ( rvec, 'All', select, d, z, ldz, sigma, bmat, -c & n, which, nev, tol, resid, ncv, v, ldv, iparam, -c & ipntr, workd, workl, lworkl, info ) -c stop -c end -c\EndDoc -c
--- a/libcruft/arpack/docs/stat.doc Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,80 +0,0 @@ -c----------------------------------------------------------------------- -c -c Include this file to get timing statistics for the different parts -c of the Arnoldi update iteration. An easy way to initialize all the -c timing information to zero at the beginning is by: -c -c call sstats <-- symmetric code -c call sstatn <-- nonsymmetric code -c call cstatn <-- complex code -c -c----------------------------------------------------------------------- -c -c nopx = total number of user OP*x operation -c nbx = total number of user B*x operation (same as copy when B = I) -c nrorth = total number of reorthogonalization steps taken -c nitref = total number of it. refinement steps in reorthogonalization -c nrstrt = total number of restart steps -c -c----------------------------------------------------------------------- -c -c======================================================== -c=== Common to both symmetric and nonsymmetric code === -c======================================================== -c -c tgetv0 = total time spent in generating starting vector and -c restarted vector for the Arnoldi sequence. -c titref = total time spent in iterative refinement phase in SSAITR. -c trvec = total time spent in computing the Ritz vectors before exit. -c -c==================================== -c=== Specific to symmetric code === -c==================================== -c -c tsaupd = total time spent in SSAUPD. -c tsaup2 = total time spent in SSAUP2. -c tsaitr = total time spent in the basic Arnoldi iteration loop, -c including iterative refinement in SSAITR. -c tseigt = total time spent in computing the tridiagonal eigenvalue -c subproblem at each iteration. -c tsgets = total time spent in getting the shifts at each iteration. -c tsapps = total time spent in applying the shifts at each iteration. -c tsconv = total time spent in convergence test at each iteration. -c -c======================================= -c=== Specific to nonsymmetric code === -c======================================= -c -c tnaupd = total time spent in SNAUPD. -c tnaup2 = total time spent in SNAUP2. -c tnaitr = total time spent in the basic Arnoldi iteration loop, -c including iterative refinement in SNAITR. -c tneigh = total time spent in computing the Hessenberg eigenvalue -c subproblem at each iteration. -c tngets = total time spent in getting the shifts at each iteration. -c tnapps = total time spent in applying the shifts at each iteration. -c tnconv = total time spent in convergence test at each iteration. -c -c================================== -c=== Specific to complex code === -c================================== -c -c tcaupd = total time spent in CNAUPD. -c tcaup2 = total time spent in CNAUP2. -c tcaitr = total time spent in the basic Arnoldi iteration loop, -c including iterative refinement in CNAITR. -c tceigh = total time spent in computing the Hessenberg eigenvalue -c subproblem at each iteration. -c tcgets = total time spent in getting the shifts at each iteration. -c tcapps = total time spent in applying the shifts at each iteration. -c tcconv = total time spent in convergence test at each iteration. -c -c================== -c=== User time === -c================== -c -c tmvopx = total time spent in computing Y = OP * X -c tmvbx = total time spent in computing Y = B * X -c -c======================================================================= -c
--- a/libcruft/arpack/module.mk Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,97 +0,0 @@ -EXTRA_DIST += \ - arpack/LICENSE \ - arpack/README \ - arpack/docs/README \ - arpack/docs/debug.doc \ - arpack/docs/ex-complex.doc \ - arpack/docs/ex-nonsym.doc \ - arpack/docs/ex-sym.doc \ - arpack/docs/stat.doc \ - arpack/module.mk \ - arpack/src/debug.h \ - arpack/src/stat.h \ - arpack/src/version.h - -libcruft_la_SOURCES += \ - arpack/src/cgetv0.f \ - arpack/src/cnaitr.f \ - arpack/src/cnapps.f \ - arpack/src/cnaup2.f \ - arpack/src/cnaupd.f \ - arpack/src/cneigh.f \ - arpack/src/cneupd.f \ - arpack/src/cngets.f \ - arpack/src/csortc.f \ - arpack/src/cstatn.f \ - arpack/src/dgetv0.f \ - arpack/src/dlaqrb.f \ - arpack/src/dnaitr.f \ - arpack/src/dnapps.f \ - arpack/src/dnaup2.f \ - arpack/src/dnaupd.f \ - arpack/src/dnconv.f \ - arpack/src/dneigh.f \ - arpack/src/dneupd.f \ - arpack/src/dngets.f \ - arpack/src/dsaitr.f \ - arpack/src/dsapps.f \ - arpack/src/dsaup2.f \ - arpack/src/dsaupd.f \ - arpack/src/dsconv.f \ - arpack/src/dseigt.f \ - arpack/src/dsesrt.f \ - arpack/src/dseupd.f \ - arpack/src/dsgets.f \ - arpack/src/dsortc.f \ - arpack/src/dsortr.f \ - arpack/src/dstatn.f \ - arpack/src/dstats.f \ - arpack/src/dstqrb.f \ - arpack/src/sgetv0.f \ - arpack/src/slaqrb.f \ - arpack/src/snaitr.f \ - arpack/src/snapps.f \ - arpack/src/snaup2.f \ - arpack/src/snaupd.f \ - arpack/src/snconv.f \ - arpack/src/sneigh.f \ - arpack/src/sneupd.f \ - arpack/src/sngets.f \ - arpack/src/ssaitr.f \ - arpack/src/ssapps.f \ - arpack/src/ssaup2.f \ - arpack/src/ssaupd.f \ - arpack/src/ssconv.f \ - arpack/src/sseigt.f \ - arpack/src/ssesrt.f \ - arpack/src/sseupd.f \ - arpack/src/ssgets.f \ - arpack/src/ssortc.f \ - arpack/src/ssortr.f \ - arpack/src/sstatn.f \ - arpack/src/sstats.f \ - arpack/src/sstqrb.f \ - arpack/src/zgetv0.f \ - arpack/src/znaitr.f \ - arpack/src/znapps.f \ - arpack/src/znaup2.f \ - arpack/src/znaupd.f \ - arpack/src/zneigh.f \ - arpack/src/zneupd.f \ - arpack/src/zngets.f \ - arpack/src/zsortc.f \ - arpack/src/zstatn.f \ - arpack/util/cmout.f \ - arpack/util/cvout.f \ - arpack/util/dmout.f \ - arpack/util/dvout.f \ - arpack/util/icnteq.f \ - arpack/util/icopy.f \ - arpack/util/iset.f \ - arpack/util/iswap.f \ - arpack/util/ivout.f \ - arpack/util/second.f \ - arpack/util/smout.f \ - arpack/util/svout.f \ - arpack/util/zmout.f \ - arpack/util/zvout.f
--- a/libcruft/arpack/src/cgetv0.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,414 +0,0 @@ -c\BeginDoc -c -c\Name: cgetv0 -c -c\Description: -c Generate a random initial residual vector for the Arnoldi process. -c Force the residual vector to be in the range of the operator OP. -c -c\Usage: -c call cgetv0 -c ( IDO, BMAT, ITRY, INITV, N, J, V, LDV, RESID, RNORM, -c IPNTR, WORKD, IERR ) -c -c\Arguments -c IDO Integer. (INPUT/OUTPUT) -c Reverse communication flag. IDO must be zero on the first -c call to cgetv0. -c ------------------------------------------------------------- -c IDO = 0: first call to the reverse communication interface -c IDO = -1: compute Y = OP * X where -c IPNTR(1) is the pointer into WORKD for X, -c IPNTR(2) is the pointer into WORKD for Y. -c This is for the initialization phase to force the -c starting vector into the range of OP. -c IDO = 2: compute Y = B * X where -c IPNTR(1) is the pointer into WORKD for X, -c IPNTR(2) is the pointer into WORKD for Y. -c IDO = 99: done -c ------------------------------------------------------------- -c -c BMAT Character*1. (INPUT) -c BMAT specifies the type of the matrix B in the (generalized) -c eigenvalue problem A*x = lambda*B*x. -c B = 'I' -> standard eigenvalue problem A*x = lambda*x -c B = 'G' -> generalized eigenvalue problem A*x = lambda*B*x -c -c ITRY Integer. (INPUT) -c ITRY counts the number of times that cgetv0 is called. -c It should be set to 1 on the initial call to cgetv0. -c -c INITV Logical variable. (INPUT) -c .TRUE. => the initial residual vector is given in RESID. -c .FALSE. => generate a random initial residual vector. -c -c N Integer. (INPUT) -c Dimension of the problem. -c -c J Integer. (INPUT) -c Index of the residual vector to be generated, with respect to -c the Arnoldi process. J > 1 in case of a "restart". -c -c V Complex N by J array. (INPUT) -c The first J-1 columns of V contain the current Arnoldi basis -c if this is a "restart". -c -c LDV Integer. (INPUT) -c Leading dimension of V exactly as declared in the calling -c program. -c -c RESID Complex array of length N. (INPUT/OUTPUT) -c Initial residual vector to be generated. If RESID is -c provided, force RESID into the range of the operator OP. -c -c RNORM Real scalar. (OUTPUT) -c B-norm of the generated residual. -c -c IPNTR Integer array of length 3. (OUTPUT) -c -c WORKD Complex work array of length 2*N. (REVERSE COMMUNICATION). -c On exit, WORK(1:N) = B*RESID to be used in SSAITR. -c -c IERR Integer. (OUTPUT) -c = 0: Normal exit. -c = -1: Cannot generate a nontrivial restarted residual vector -c in the range of the operator OP. -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Local variables: -c xxxxxx Complex -c -c\References: -c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in -c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), -c pp 357-385. -c -c\Routines called: -c arscnd ARPACK utility routine for timing. -c cvout ARPACK utility routine that prints vectors. -c clarnv LAPACK routine for generating a random vector. -c cgemv Level 2 BLAS routine for matrix vector multiplication. -c ccopy Level 1 BLAS that copies one vector to another. -c cdotc Level 1 BLAS that computes the scalar product of two vectors. -c scnrm2 Level 1 BLAS that computes the norm of a vector. -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\SCCS Information: @(#) -c FILE: getv0.F SID: 2.3 DATE OF SID: 08/27/96 RELEASE: 2 -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine cgetv0 - & ( ido, bmat, itry, initv, n, j, v, ldv, resid, rnorm, - & ipntr, workd, ierr ) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - character bmat*1 - logical initv - integer ido, ierr, itry, j, ldv, n - Real - & rnorm -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - integer ipntr(3) - Complex - & resid(n), v(ldv,j), workd(2*n) -c -c %------------% -c | Parameters | -c %------------% -c - Complex - & one, zero - Real - & rzero - parameter (one = (1.0E+0, 0.0E+0), zero = (0.0E+0, 0.0E+0), - & rzero = 0.0E+0) -c -c %------------------------% -c | Local Scalars & Arrays | -c %------------------------% -c - logical first, inits, orth - integer idist, iseed(4), iter, msglvl, jj - Real - & rnorm0 - Complex - & cnorm - save first, iseed, inits, iter, msglvl, orth, rnorm0 -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external ccopy, cgemv, clarnv, cvout, arscnd -c -c %--------------------% -c | External Functions | -c %--------------------% -c - Real - & scnrm2, slapy2 - Complex - & cdotc - external cdotc, scnrm2, slapy2 -c -c %-----------------% -c | Data Statements | -c %-----------------% -c - data inits /.true./ -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c -c -c %-----------------------------------% -c | Initialize the seed of the LAPACK | -c | random number generator | -c %-----------------------------------% -c - if (inits) then - iseed(1) = 1 - iseed(2) = 3 - iseed(3) = 5 - iseed(4) = 7 - inits = .false. - end if -c - if (ido .eq. 0) then -c -c %-------------------------------% -c | Initialize timing statistics | -c | & message level for debugging | -c %-------------------------------% -c - call arscnd (t0) - msglvl = mgetv0 -c - ierr = 0 - iter = 0 - first = .FALSE. - orth = .FALSE. -c -c %-----------------------------------------------------% -c | Possibly generate a random starting vector in RESID | -c | Use a LAPACK random number generator used by the | -c | matrix generation routines. | -c | idist = 1: uniform (0,1) distribution; | -c | idist = 2: uniform (-1,1) distribution; | -c | idist = 3: normal (0,1) distribution; | -c %-----------------------------------------------------% -c - if (.not.initv) then - idist = 2 - call clarnv (idist, iseed, n, resid) - end if -c -c %----------------------------------------------------------% -c | Force the starting vector into the range of OP to handle | -c | the generalized problem when B is possibly (singular). | -c %----------------------------------------------------------% -c - call arscnd (t2) - if (bmat .eq. 'G') then - nopx = nopx + 1 - ipntr(1) = 1 - ipntr(2) = n + 1 - call ccopy (n, resid, 1, workd, 1) - ido = -1 - go to 9000 - end if - end if -c -c %----------------------------------------% -c | Back from computing B*(initial-vector) | -c %----------------------------------------% -c - if (first) go to 20 -c -c %-----------------------------------------------% -c | Back from computing B*(orthogonalized-vector) | -c %-----------------------------------------------% -c - if (orth) go to 40 -c - call arscnd (t3) - tmvopx = tmvopx + (t3 - t2) -c -c %------------------------------------------------------% -c | Starting vector is now in the range of OP; r = OP*r; | -c | Compute B-norm of starting vector. | -c %------------------------------------------------------% -c - call arscnd (t2) - first = .TRUE. - if (bmat .eq. 'G') then - nbx = nbx + 1 - call ccopy (n, workd(n+1), 1, resid, 1) - ipntr(1) = n + 1 - ipntr(2) = 1 - ido = 2 - go to 9000 - else if (bmat .eq. 'I') then - call ccopy (n, resid, 1, workd, 1) - end if -c - 20 continue -c - if (bmat .eq. 'G') then - call arscnd (t3) - tmvbx = tmvbx + (t3 - t2) - end if -c - first = .FALSE. - if (bmat .eq. 'G') then - cnorm = cdotc (n, resid, 1, workd, 1) - rnorm0 = sqrt(slapy2(real(cnorm),aimag(cnorm))) - else if (bmat .eq. 'I') then - rnorm0 = scnrm2(n, resid, 1) - end if - rnorm = rnorm0 -c -c %---------------------------------------------% -c | Exit if this is the very first Arnoldi step | -c %---------------------------------------------% -c - if (j .eq. 1) go to 50 -c -c %---------------------------------------------------------------- -c | Otherwise need to B-orthogonalize the starting vector against | -c | the current Arnoldi basis using Gram-Schmidt with iter. ref. | -c | This is the case where an invariant subspace is encountered | -c | in the middle of the Arnoldi factorization. | -c | | -c | s = V^{T}*B*r; r = r - V*s; | -c | | -c | Stopping criteria used for iter. ref. is discussed in | -c | Parlett's book, page 107 and in Gragg & Reichel TOMS paper. | -c %---------------------------------------------------------------% -c - orth = .TRUE. - 30 continue -c - call cgemv ('C', n, j-1, one, v, ldv, workd, 1, - & zero, workd(n+1), 1) - call cgemv ('N', n, j-1, -one, v, ldv, workd(n+1), 1, - & one, resid, 1) -c -c %----------------------------------------------------------% -c | Compute the B-norm of the orthogonalized starting vector | -c %----------------------------------------------------------% -c - call arscnd (t2) - if (bmat .eq. 'G') then - nbx = nbx + 1 - call ccopy (n, resid, 1, workd(n+1), 1) - ipntr(1) = n + 1 - ipntr(2) = 1 - ido = 2 - go to 9000 - else if (bmat .eq. 'I') then - call ccopy (n, resid, 1, workd, 1) - end if -c - 40 continue -c - if (bmat .eq. 'G') then - call arscnd (t3) - tmvbx = tmvbx + (t3 - t2) - end if -c - if (bmat .eq. 'G') then - cnorm = cdotc (n, resid, 1, workd, 1) - rnorm = sqrt(slapy2(real(cnorm),aimag(cnorm))) - else if (bmat .eq. 'I') then - rnorm = scnrm2(n, resid, 1) - end if -c -c %--------------------------------------% -c | Check for further orthogonalization. | -c %--------------------------------------% -c - if (msglvl .gt. 2) then - call svout (logfil, 1, rnorm0, ndigit, - & '_getv0: re-orthonalization ; rnorm0 is') - call svout (logfil, 1, rnorm, ndigit, - & '_getv0: re-orthonalization ; rnorm is') - end if -c - if (rnorm .gt. 0.717*rnorm0) go to 50 -c - iter = iter + 1 - if (iter .le. 1) then -c -c %-----------------------------------% -c | Perform iterative refinement step | -c %-----------------------------------% -c - rnorm0 = rnorm - go to 30 - else -c -c %------------------------------------% -c | Iterative refinement step "failed" | -c %------------------------------------% -c - do 45 jj = 1, n - resid(jj) = zero - 45 continue - rnorm = rzero - ierr = -1 - end if -c - 50 continue -c - if (msglvl .gt. 0) then - call svout (logfil, 1, rnorm, ndigit, - & '_getv0: B-norm of initial / restarted starting vector') - end if - if (msglvl .gt. 2) then - call cvout (logfil, n, resid, ndigit, - & '_getv0: initial / restarted starting vector') - end if - ido = 99 -c - call arscnd (t1) - tgetv0 = tgetv0 + (t1 - t0) -c - 9000 continue - return -c -c %---------------% -c | End of cgetv0 | -c %---------------% -c - end
--- a/libcruft/arpack/src/cnaitr.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,850 +0,0 @@ -c\BeginDoc -c -c\Name: cnaitr -c -c\Description: -c Reverse communication interface for applying NP additional steps to -c a K step nonsymmetric Arnoldi factorization. -c -c Input: OP*V_{k} - V_{k}*H = r_{k}*e_{k}^T -c -c with (V_{k}^T)*B*V_{k} = I, (V_{k}^T)*B*r_{k} = 0. -c -c Output: OP*V_{k+p} - V_{k+p}*H = r_{k+p}*e_{k+p}^T -c -c with (V_{k+p}^T)*B*V_{k+p} = I, (V_{k+p}^T)*B*r_{k+p} = 0. -c -c where OP and B are as in cnaupd. The B-norm of r_{k+p} is also -c computed and returned. -c -c\Usage: -c call cnaitr -c ( IDO, BMAT, N, K, NP, NB, RESID, RNORM, V, LDV, H, LDH, -c IPNTR, WORKD, INFO ) -c -c\Arguments -c IDO Integer. (INPUT/OUTPUT) -c Reverse communication flag. -c ------------------------------------------------------------- -c IDO = 0: first call to the reverse communication interface -c IDO = -1: compute Y = OP * X where -c IPNTR(1) is the pointer into WORK for X, -c IPNTR(2) is the pointer into WORK for Y. -c This is for the restart phase to force the new -c starting vector into the range of OP. -c IDO = 1: compute Y = OP * X where -c IPNTR(1) is the pointer into WORK for X, -c IPNTR(2) is the pointer into WORK for Y, -c IPNTR(3) is the pointer into WORK for B * X. -c IDO = 2: compute Y = B * X where -c IPNTR(1) is the pointer into WORK for X, -c IPNTR(2) is the pointer into WORK for Y. -c IDO = 99: done -c ------------------------------------------------------------- -c When the routine is used in the "shift-and-invert" mode, the -c vector B * Q is already available and do not need to be -c recomputed in forming OP * Q. -c -c BMAT Character*1. (INPUT) -c BMAT specifies the type of the matrix B that defines the -c semi-inner product for the operator OP. See cnaupd. -c B = 'I' -> standard eigenvalue problem A*x = lambda*x -c B = 'G' -> generalized eigenvalue problem A*x = lambda*M**x -c -c N Integer. (INPUT) -c Dimension of the eigenproblem. -c -c K Integer. (INPUT) -c Current size of V and H. -c -c NP Integer. (INPUT) -c Number of additional Arnoldi steps to take. -c -c NB Integer. (INPUT) -c Blocksize to be used in the recurrence. -c Only work for NB = 1 right now. The goal is to have a -c program that implement both the block and non-block method. -c -c RESID Complex array of length N. (INPUT/OUTPUT) -c On INPUT: RESID contains the residual vector r_{k}. -c On OUTPUT: RESID contains the residual vector r_{k+p}. -c -c RNORM Real scalar. (INPUT/OUTPUT) -c B-norm of the starting residual on input. -c B-norm of the updated residual r_{k+p} on output. -c -c V Complex N by K+NP array. (INPUT/OUTPUT) -c On INPUT: V contains the Arnoldi vectors in the first K -c columns. -c On OUTPUT: V contains the new NP Arnoldi vectors in the next -c NP columns. The first K columns are unchanged. -c -c LDV Integer. (INPUT) -c Leading dimension of V exactly as declared in the calling -c program. -c -c H Complex (K+NP) by (K+NP) array. (INPUT/OUTPUT) -c H is used to store the generated upper Hessenberg matrix. -c -c LDH Integer. (INPUT) -c Leading dimension of H exactly as declared in the calling -c program. -c -c IPNTR Integer array of length 3. (OUTPUT) -c Pointer to mark the starting locations in the WORK for -c vectors used by the Arnoldi iteration. -c ------------------------------------------------------------- -c IPNTR(1): pointer to the current operand vector X. -c IPNTR(2): pointer to the current result vector Y. -c IPNTR(3): pointer to the vector B * X when used in the -c shift-and-invert mode. X is the current operand. -c ------------------------------------------------------------- -c -c WORKD Complex work array of length 3*N. (REVERSE COMMUNICATION) -c Distributed array to be used in the basic Arnoldi iteration -c for reverse communication. The calling program should not -c use WORKD as temporary workspace during the iteration !!!!!! -c On input, WORKD(1:N) = B*RESID and is used to save some -c computation at the first step. -c -c INFO Integer. (OUTPUT) -c = 0: Normal exit. -c > 0: Size of the spanning invariant subspace of OP found. -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Local variables: -c xxxxxx Complex -c -c\References: -c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in -c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), -c pp 357-385. -c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly -c Restarted Arnoldi Iteration", Rice University Technical Report -c TR95-13, Department of Computational and Applied Mathematics. -c -c\Routines called: -c cgetv0 ARPACK routine to generate the initial vector. -c ivout ARPACK utility routine that prints integers. -c arscnd ARPACK utility routine for timing. -c cmout ARPACK utility routine that prints matrices -c cvout ARPACK utility routine that prints vectors. -c clanhs LAPACK routine that computes various norms of a matrix. -c clascl LAPACK routine for careful scaling of a matrix. -c slabad LAPACK routine for defining the underflow and overflow -c limits. -c slamch LAPACK routine that determines machine constants. -c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. -c cgemv Level 2 BLAS routine for matrix vector multiplication. -c caxpy Level 1 BLAS that computes a vector triad. -c ccopy Level 1 BLAS that copies one vector to another . -c cdotc Level 1 BLAS that computes the scalar product of two vectors. -c cscal Level 1 BLAS that scales a vector. -c csscal Level 1 BLAS that scales a complex vector by a real number. -c scnrm2 Level 1 BLAS that computes the norm of a vector. -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\SCCS Information: @(#) -c FILE: naitr.F SID: 2.3 DATE OF SID: 8/27/96 RELEASE: 2 -c -c\Remarks -c The algorithm implemented is: -c -c restart = .false. -c Given V_{k} = [v_{1}, ..., v_{k}], r_{k}; -c r_{k} contains the initial residual vector even for k = 0; -c Also assume that rnorm = || B*r_{k} || and B*r_{k} are already -c computed by the calling program. -c -c betaj = rnorm ; p_{k+1} = B*r_{k} ; -c For j = k+1, ..., k+np Do -c 1) if ( betaj < tol ) stop or restart depending on j. -c ( At present tol is zero ) -c if ( restart ) generate a new starting vector. -c 2) v_{j} = r(j-1)/betaj; V_{j} = [V_{j-1}, v_{j}]; -c p_{j} = p_{j}/betaj -c 3) r_{j} = OP*v_{j} where OP is defined as in cnaupd -c For shift-invert mode p_{j} = B*v_{j} is already available. -c wnorm = || OP*v_{j} || -c 4) Compute the j-th step residual vector. -c w_{j} = V_{j}^T * B * OP * v_{j} -c r_{j} = OP*v_{j} - V_{j} * w_{j} -c H(:,j) = w_{j}; -c H(j,j-1) = rnorm -c rnorm = || r_(j) || -c If (rnorm > 0.717*wnorm) accept step and go back to 1) -c 5) Re-orthogonalization step: -c s = V_{j}'*B*r_{j} -c r_{j} = r_{j} - V_{j}*s; rnorm1 = || r_{j} || -c alphaj = alphaj + s_{j}; -c 6) Iterative refinement step: -c If (rnorm1 > 0.717*rnorm) then -c rnorm = rnorm1 -c accept step and go back to 1) -c Else -c rnorm = rnorm1 -c If this is the first time in step 6), go to 5) -c Else r_{j} lies in the span of V_{j} numerically. -c Set r_{j} = 0 and rnorm = 0; go to 1) -c EndIf -c End Do -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine cnaitr - & (ido, bmat, n, k, np, nb, resid, rnorm, v, ldv, h, ldh, - & ipntr, workd, info) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - character bmat*1 - integer ido, info, k, ldh, ldv, n, nb, np - Real - & rnorm -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - integer ipntr(3) - Complex - & h(ldh,k+np), resid(n), v(ldv,k+np), workd(3*n) -c -c %------------% -c | Parameters | -c %------------% -c - Complex - & one, zero - Real - & rone, rzero - parameter (one = (1.0E+0, 0.0E+0), zero = (0.0E+0, 0.0E+0), - & rone = 1.0E+0, rzero = 0.0E+0) -c -c %--------------% -c | Local Arrays | -c %--------------% -c - Real - & rtemp(2) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - logical first, orth1, orth2, rstart, step3, step4 - integer ierr, i, infol, ipj, irj, ivj, iter, itry, j, msglvl, - & jj - Real - & ovfl, smlnum, tst1, ulp, unfl, betaj, - & temp1, rnorm1, wnorm - Complex - & cnorm -c - save first, orth1, orth2, rstart, step3, step4, - & ierr, ipj, irj, ivj, iter, itry, j, msglvl, ovfl, - & betaj, rnorm1, smlnum, ulp, unfl, wnorm -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external caxpy, ccopy, cscal, csscal, cgemv, cgetv0, - & slabad, cvout, cmout, ivout, arscnd -c -c %--------------------% -c | External Functions | -c %--------------------% -c - Complex - & cdotc - Real - & slamch, scnrm2, clanhs, slapy2 - external cdotc, scnrm2, clanhs, slamch, slapy2 -c -c %---------------------% -c | Intrinsic Functions | -c %---------------------% -c - intrinsic aimag, real, max, sqrt -c -c %-----------------% -c | Data statements | -c %-----------------% -c - data first / .true. / -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c - if (first) then -c -c %-----------------------------------------% -c | Set machine-dependent constants for the | -c | the splitting and deflation criterion. | -c | If norm(H) <= sqrt(OVFL), | -c | overflow should not occur. | -c | REFERENCE: LAPACK subroutine clahqr | -c %-----------------------------------------% -c - unfl = slamch( 'safe minimum' ) - ovfl = real(one / unfl) - call slabad( unfl, ovfl ) - ulp = slamch( 'precision' ) - smlnum = unfl*( n / ulp ) - first = .false. - end if -c - if (ido .eq. 0) then -c -c %-------------------------------% -c | Initialize timing statistics | -c | & message level for debugging | -c %-------------------------------% -c - call arscnd (t0) - msglvl = mcaitr -c -c %------------------------------% -c | Initial call to this routine | -c %------------------------------% -c - info = 0 - step3 = .false. - step4 = .false. - rstart = .false. - orth1 = .false. - orth2 = .false. - j = k + 1 - ipj = 1 - irj = ipj + n - ivj = irj + n - end if -c -c %-------------------------------------------------% -c | When in reverse communication mode one of: | -c | STEP3, STEP4, ORTH1, ORTH2, RSTART | -c | will be .true. when .... | -c | STEP3: return from computing OP*v_{j}. | -c | STEP4: return from computing B-norm of OP*v_{j} | -c | ORTH1: return from computing B-norm of r_{j+1} | -c | ORTH2: return from computing B-norm of | -c | correction to the residual vector. | -c | RSTART: return from OP computations needed by | -c | cgetv0. | -c %-------------------------------------------------% -c - if (step3) go to 50 - if (step4) go to 60 - if (orth1) go to 70 - if (orth2) go to 90 - if (rstart) go to 30 -c -c %-----------------------------% -c | Else this is the first step | -c %-----------------------------% -c -c %--------------------------------------------------------------% -c | | -c | A R N O L D I I T E R A T I O N L O O P | -c | | -c | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) | -c %--------------------------------------------------------------% - - 1000 continue -c - if (msglvl .gt. 1) then - call ivout (logfil, 1, j, ndigit, - & '_naitr: generating Arnoldi vector number') - call svout (logfil, 1, rnorm, ndigit, - & '_naitr: B-norm of the current residual is') - end if -c -c %---------------------------------------------------% -c | STEP 1: Check if the B norm of j-th residual | -c | vector is zero. Equivalent to determine whether | -c | an exact j-step Arnoldi factorization is present. | -c %---------------------------------------------------% -c - betaj = rnorm - if (rnorm .gt. rzero) go to 40 -c -c %---------------------------------------------------% -c | Invariant subspace found, generate a new starting | -c | vector which is orthogonal to the current Arnoldi | -c | basis and continue the iteration. | -c %---------------------------------------------------% -c - if (msglvl .gt. 0) then - call ivout (logfil, 1, j, ndigit, - & '_naitr: ****** RESTART AT STEP ******') - end if -c -c %---------------------------------------------% -c | ITRY is the loop variable that controls the | -c | maximum amount of times that a restart is | -c | attempted. NRSTRT is used by stat.h | -c %---------------------------------------------% -c - betaj = rzero - nrstrt = nrstrt + 1 - itry = 1 - 20 continue - rstart = .true. - ido = 0 - 30 continue -c -c %--------------------------------------% -c | If in reverse communication mode and | -c | RSTART = .true. flow returns here. | -c %--------------------------------------% -c - call cgetv0 (ido, bmat, itry, .false., n, j, v, ldv, - & resid, rnorm, ipntr, workd, ierr) - if (ido .ne. 99) go to 9000 - if (ierr .lt. 0) then - itry = itry + 1 - if (itry .le. 3) go to 20 -c -c %------------------------------------------------% -c | Give up after several restart attempts. | -c | Set INFO to the size of the invariant subspace | -c | which spans OP and exit. | -c %------------------------------------------------% -c - info = j - 1 - call arscnd (t1) - tcaitr = tcaitr + (t1 - t0) - ido = 99 - go to 9000 - end if -c - 40 continue -c -c %---------------------------------------------------------% -c | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm | -c | Note that p_{j} = B*r_{j-1}. In order to avoid overflow | -c | when reciprocating a small RNORM, test against lower | -c | machine bound. | -c %---------------------------------------------------------% -c - call ccopy (n, resid, 1, v(1,j), 1) - if ( rnorm .ge. unfl) then - temp1 = rone / rnorm - call csscal (n, temp1, v(1,j), 1) - call csscal (n, temp1, workd(ipj), 1) - else -c -c %-----------------------------------------% -c | To scale both v_{j} and p_{j} carefully | -c | use LAPACK routine clascl | -c %-----------------------------------------% -c - call clascl ('General', i, i, rnorm, rone, - & n, 1, v(1,j), n, infol) - call clascl ('General', i, i, rnorm, rone, - & n, 1, workd(ipj), n, infol) - end if -c -c %------------------------------------------------------% -c | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} | -c | Note that this is not quite yet r_{j}. See STEP 4 | -c %------------------------------------------------------% -c - step3 = .true. - nopx = nopx + 1 - call arscnd (t2) - call ccopy (n, v(1,j), 1, workd(ivj), 1) - ipntr(1) = ivj - ipntr(2) = irj - ipntr(3) = ipj - ido = 1 -c -c %-----------------------------------% -c | Exit in order to compute OP*v_{j} | -c %-----------------------------------% -c - go to 9000 - 50 continue -c -c %----------------------------------% -c | Back from reverse communication; | -c | WORKD(IRJ:IRJ+N-1) := OP*v_{j} | -c | if step3 = .true. | -c %----------------------------------% -c - call arscnd (t3) - tmvopx = tmvopx + (t3 - t2) - - step3 = .false. -c -c %------------------------------------------% -c | Put another copy of OP*v_{j} into RESID. | -c %------------------------------------------% -c - call ccopy (n, workd(irj), 1, resid, 1) -c -c %---------------------------------------% -c | STEP 4: Finish extending the Arnoldi | -c | factorization to length j. | -c %---------------------------------------% -c - call arscnd (t2) - if (bmat .eq. 'G') then - nbx = nbx + 1 - step4 = .true. - ipntr(1) = irj - ipntr(2) = ipj - ido = 2 -c -c %-------------------------------------% -c | Exit in order to compute B*OP*v_{j} | -c %-------------------------------------% -c - go to 9000 - else if (bmat .eq. 'I') then - call ccopy (n, resid, 1, workd(ipj), 1) - end if - 60 continue -c -c %----------------------------------% -c | Back from reverse communication; | -c | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j} | -c | if step4 = .true. | -c %----------------------------------% -c - if (bmat .eq. 'G') then - call arscnd (t3) - tmvbx = tmvbx + (t3 - t2) - end if -c - step4 = .false. -c -c %-------------------------------------% -c | The following is needed for STEP 5. | -c | Compute the B-norm of OP*v_{j}. | -c %-------------------------------------% -c - if (bmat .eq. 'G') then - cnorm = cdotc (n, resid, 1, workd(ipj), 1) - wnorm = sqrt( slapy2(real(cnorm),aimag(cnorm)) ) - else if (bmat .eq. 'I') then - wnorm = scnrm2(n, resid, 1) - end if -c -c %-----------------------------------------% -c | Compute the j-th residual corresponding | -c | to the j step factorization. | -c | Use Classical Gram Schmidt and compute: | -c | w_{j} <- V_{j}^T * B * OP * v_{j} | -c | r_{j} <- OP*v_{j} - V_{j} * w_{j} | -c %-----------------------------------------% -c -c -c %------------------------------------------% -c | Compute the j Fourier coefficients w_{j} | -c | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. | -c %------------------------------------------% -c - call cgemv ('C', n, j, one, v, ldv, workd(ipj), 1, - & zero, h(1,j), 1) -c -c %--------------------------------------% -c | Orthogonalize r_{j} against V_{j}. | -c | RESID contains OP*v_{j}. See STEP 3. | -c %--------------------------------------% -c - call cgemv ('N', n, j, -one, v, ldv, h(1,j), 1, - & one, resid, 1) -c - if (j .gt. 1) h(j,j-1) = cmplx(betaj, rzero) -c - call arscnd (t4) -c - orth1 = .true. -c - call arscnd (t2) - if (bmat .eq. 'G') then - nbx = nbx + 1 - call ccopy (n, resid, 1, workd(irj), 1) - ipntr(1) = irj - ipntr(2) = ipj - ido = 2 -c -c %----------------------------------% -c | Exit in order to compute B*r_{j} | -c %----------------------------------% -c - go to 9000 - else if (bmat .eq. 'I') then - call ccopy (n, resid, 1, workd(ipj), 1) - end if - 70 continue -c -c %---------------------------------------------------% -c | Back from reverse communication if ORTH1 = .true. | -c | WORKD(IPJ:IPJ+N-1) := B*r_{j}. | -c %---------------------------------------------------% -c - if (bmat .eq. 'G') then - call arscnd (t3) - tmvbx = tmvbx + (t3 - t2) - end if -c - orth1 = .false. -c -c %------------------------------% -c | Compute the B-norm of r_{j}. | -c %------------------------------% -c - if (bmat .eq. 'G') then - cnorm = cdotc (n, resid, 1, workd(ipj), 1) - rnorm = sqrt( slapy2(real(cnorm),aimag(cnorm)) ) - else if (bmat .eq. 'I') then - rnorm = scnrm2(n, resid, 1) - end if -c -c %-----------------------------------------------------------% -c | STEP 5: Re-orthogonalization / Iterative refinement phase | -c | Maximum NITER_ITREF tries. | -c | | -c | s = V_{j}^T * B * r_{j} | -c | r_{j} = r_{j} - V_{j}*s | -c | alphaj = alphaj + s_{j} | -c | | -c | The stopping criteria used for iterative refinement is | -c | discussed in Parlett's book SEP, page 107 and in Gragg & | -c | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. | -c | Determine if we need to correct the residual. The goal is | -c | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || | -c | The following test determines whether the sine of the | -c | angle between OP*x and the computed residual is less | -c | than or equal to 0.717. | -c %-----------------------------------------------------------% -c - if ( rnorm .gt. 0.717*wnorm ) go to 100 -c - iter = 0 - nrorth = nrorth + 1 -c -c %---------------------------------------------------% -c | Enter the Iterative refinement phase. If further | -c | refinement is necessary, loop back here. The loop | -c | variable is ITER. Perform a step of Classical | -c | Gram-Schmidt using all the Arnoldi vectors V_{j} | -c %---------------------------------------------------% -c - 80 continue -c - if (msglvl .gt. 2) then - rtemp(1) = wnorm - rtemp(2) = rnorm - call svout (logfil, 2, rtemp, ndigit, - & '_naitr: re-orthogonalization; wnorm and rnorm are') - call cvout (logfil, j, h(1,j), ndigit, - & '_naitr: j-th column of H') - end if -c -c %----------------------------------------------------% -c | Compute V_{j}^T * B * r_{j}. | -c | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). | -c %----------------------------------------------------% -c - call cgemv ('C', n, j, one, v, ldv, workd(ipj), 1, - & zero, workd(irj), 1) -c -c %---------------------------------------------% -c | Compute the correction to the residual: | -c | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). | -c | The correction to H is v(:,1:J)*H(1:J,1:J) | -c | + v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j. | -c %---------------------------------------------% -c - call cgemv ('N', n, j, -one, v, ldv, workd(irj), 1, - & one, resid, 1) - call caxpy (j, one, workd(irj), 1, h(1,j), 1) -c - orth2 = .true. - call arscnd (t2) - if (bmat .eq. 'G') then - nbx = nbx + 1 - call ccopy (n, resid, 1, workd(irj), 1) - ipntr(1) = irj - ipntr(2) = ipj - ido = 2 -c -c %-----------------------------------% -c | Exit in order to compute B*r_{j}. | -c | r_{j} is the corrected residual. | -c %-----------------------------------% -c - go to 9000 - else if (bmat .eq. 'I') then - call ccopy (n, resid, 1, workd(ipj), 1) - end if - 90 continue -c -c %---------------------------------------------------% -c | Back from reverse communication if ORTH2 = .true. | -c %---------------------------------------------------% -c - if (bmat .eq. 'G') then - call arscnd (t3) - tmvbx = tmvbx + (t3 - t2) - end if -c -c %-----------------------------------------------------% -c | Compute the B-norm of the corrected residual r_{j}. | -c %-----------------------------------------------------% -c - if (bmat .eq. 'G') then - cnorm = cdotc (n, resid, 1, workd(ipj), 1) - rnorm1 = sqrt( slapy2(real(cnorm),aimag(cnorm)) ) - else if (bmat .eq. 'I') then - rnorm1 = scnrm2(n, resid, 1) - end if -c - if (msglvl .gt. 0 .and. iter .gt. 0 ) then - call ivout (logfil, 1, j, ndigit, - & '_naitr: Iterative refinement for Arnoldi residual') - if (msglvl .gt. 2) then - rtemp(1) = rnorm - rtemp(2) = rnorm1 - call svout (logfil, 2, rtemp, ndigit, - & '_naitr: iterative refinement ; rnorm and rnorm1 are') - end if - end if -c -c %-----------------------------------------% -c | Determine if we need to perform another | -c | step of re-orthogonalization. | -c %-----------------------------------------% -c - if ( rnorm1 .gt. 0.717*rnorm ) then -c -c %---------------------------------------% -c | No need for further refinement. | -c | The cosine of the angle between the | -c | corrected residual vector and the old | -c | residual vector is greater than 0.717 | -c | In other words the corrected residual | -c | and the old residual vector share an | -c | angle of less than arcCOS(0.717) | -c %---------------------------------------% -c - rnorm = rnorm1 -c - else -c -c %-------------------------------------------% -c | Another step of iterative refinement step | -c | is required. NITREF is used by stat.h | -c %-------------------------------------------% -c - nitref = nitref + 1 - rnorm = rnorm1 - iter = iter + 1 - if (iter .le. 1) go to 80 -c -c %-------------------------------------------------% -c | Otherwise RESID is numerically in the span of V | -c %-------------------------------------------------% -c - do 95 jj = 1, n - resid(jj) = zero - 95 continue - rnorm = rzero - end if -c -c %----------------------------------------------% -c | Branch here directly if iterative refinement | -c | wasn't necessary or after at most NITER_REF | -c | steps of iterative refinement. | -c %----------------------------------------------% -c - 100 continue -c - rstart = .false. - orth2 = .false. -c - call arscnd (t5) - titref = titref + (t5 - t4) -c -c %------------------------------------% -c | STEP 6: Update j = j+1; Continue | -c %------------------------------------% -c - j = j + 1 - if (j .gt. k+np) then - call arscnd (t1) - tcaitr = tcaitr + (t1 - t0) - ido = 99 - do 110 i = max(1,k), k+np-1 -c -c %--------------------------------------------% -c | Check for splitting and deflation. | -c | Use a standard test as in the QR algorithm | -c | REFERENCE: LAPACK subroutine clahqr | -c %--------------------------------------------% -c - tst1 = slapy2(real(h(i,i)),aimag(h(i,i))) - & + slapy2(real(h(i+1,i+1)), aimag(h(i+1,i+1))) - if( tst1.eq.real(zero) ) - & tst1 = clanhs( '1', k+np, h, ldh, workd(n+1) ) - if( slapy2(real(h(i+1,i)),aimag(h(i+1,i))) .le. - & max( ulp*tst1, smlnum ) ) - & h(i+1,i) = zero - 110 continue -c - if (msglvl .gt. 2) then - call cmout (logfil, k+np, k+np, h, ldh, ndigit, - & '_naitr: Final upper Hessenberg matrix H of order K+NP') - end if -c - go to 9000 - end if -c -c %--------------------------------------------------------% -c | Loop back to extend the factorization by another step. | -c %--------------------------------------------------------% -c - go to 1000 -c -c %---------------------------------------------------------------% -c | | -c | E N D O F M A I N I T E R A T I O N L O O P | -c | | -c %---------------------------------------------------------------% -c - 9000 continue - return -c -c %---------------% -c | End of cnaitr | -c %---------------% -c - end
--- a/libcruft/arpack/src/cnapps.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,507 +0,0 @@ -c\BeginDoc -c -c\Name: cnapps -c -c\Description: -c Given the Arnoldi factorization -c -c A*V_{k} - V_{k}*H_{k} = r_{k+p}*e_{k+p}^T, -c -c apply NP implicit shifts resulting in -c -c A*(V_{k}*Q) - (V_{k}*Q)*(Q^T* H_{k}*Q) = r_{k+p}*e_{k+p}^T * Q -c -c where Q is an orthogonal matrix which is the product of rotations -c and reflections resulting from the NP bulge change sweeps. -c The updated Arnoldi factorization becomes: -c -c A*VNEW_{k} - VNEW_{k}*HNEW_{k} = rnew_{k}*e_{k}^T. -c -c\Usage: -c call cnapps -c ( N, KEV, NP, SHIFT, V, LDV, H, LDH, RESID, Q, LDQ, -c WORKL, WORKD ) -c -c\Arguments -c N Integer. (INPUT) -c Problem size, i.e. size of matrix A. -c -c KEV Integer. (INPUT/OUTPUT) -c KEV+NP is the size of the input matrix H. -c KEV is the size of the updated matrix HNEW. -c -c NP Integer. (INPUT) -c Number of implicit shifts to be applied. -c -c SHIFT Complex array of length NP. (INPUT) -c The shifts to be applied. -c -c V Complex N by (KEV+NP) array. (INPUT/OUTPUT) -c On INPUT, V contains the current KEV+NP Arnoldi vectors. -c On OUTPUT, V contains the updated KEV Arnoldi vectors -c in the first KEV columns of V. -c -c LDV Integer. (INPUT) -c Leading dimension of V exactly as declared in the calling -c program. -c -c H Complex (KEV+NP) by (KEV+NP) array. (INPUT/OUTPUT) -c On INPUT, H contains the current KEV+NP by KEV+NP upper -c Hessenberg matrix of the Arnoldi factorization. -c On OUTPUT, H contains the updated KEV by KEV upper Hessenberg -c matrix in the KEV leading submatrix. -c -c LDH Integer. (INPUT) -c Leading dimension of H exactly as declared in the calling -c program. -c -c RESID Complex array of length N. (INPUT/OUTPUT) -c On INPUT, RESID contains the the residual vector r_{k+p}. -c On OUTPUT, RESID is the update residual vector rnew_{k} -c in the first KEV locations. -c -c Q Complex KEV+NP by KEV+NP work array. (WORKSPACE) -c Work array used to accumulate the rotations and reflections -c during the bulge chase sweep. -c -c LDQ Integer. (INPUT) -c Leading dimension of Q exactly as declared in the calling -c program. -c -c WORKL Complex work array of length (KEV+NP). (WORKSPACE) -c Private (replicated) array on each PE or array allocated on -c the front end. -c -c WORKD Complex work array of length 2*N. (WORKSPACE) -c Distributed array used in the application of the accumulated -c orthogonal matrix Q. -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Local variables: -c xxxxxx Complex -c -c\References: -c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in -c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), -c pp 357-385. -c -c\Routines called: -c ivout ARPACK utility routine that prints integers. -c arscnd ARPACK utility routine for timing. -c cmout ARPACK utility routine that prints matrices -c cvout ARPACK utility routine that prints vectors. -c clacpy LAPACK matrix copy routine. -c clanhs LAPACK routine that computes various norms of a matrix. -c clartg LAPACK Givens rotation construction routine. -c claset LAPACK matrix initialization routine. -c slabad LAPACK routine for defining the underflow and overflow -c limits. -c slamch LAPACK routine that determines machine constants. -c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. -c cgemv Level 2 BLAS routine for matrix vector multiplication. -c caxpy Level 1 BLAS that computes a vector triad. -c ccopy Level 1 BLAS that copies one vector to another. -c cscal Level 1 BLAS that scales a vector. -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\SCCS Information: @(#) -c FILE: napps.F SID: 2.3 DATE OF SID: 3/28/97 RELEASE: 2 -c -c\Remarks -c 1. In this version, each shift is applied to all the sublocks of -c the Hessenberg matrix H and not just to the submatrix that it -c comes from. Deflation as in LAPACK routine clahqr (QR algorithm -c for upper Hessenberg matrices ) is used. -c Upon output, the subdiagonals of H are enforced to be non-negative -c real numbers. -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine cnapps - & ( n, kev, np, shift, v, ldv, h, ldh, resid, q, ldq, - & workl, workd ) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - integer kev, ldh, ldq, ldv, n, np -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - Complex - & h(ldh,kev+np), resid(n), shift(np), - & v(ldv,kev+np), q(ldq,kev+np), workd(2*n), workl(kev+np) -c -c %------------% -c | Parameters | -c %------------% -c - Complex - & one, zero - Real - & rzero - parameter (one = (1.0E+0, 0.0E+0), zero = (0.0E+0, 0.0E+0), - & rzero = 0.0E+0) -c -c %------------------------% -c | Local Scalars & Arrays | -c %------------------------% -c - integer i, iend, istart, j, jj, kplusp, msglvl - logical first - Complex - & cdum, f, g, h11, h21, r, s, sigma, t - Real - & c, ovfl, smlnum, ulp, unfl, tst1 - save first, ovfl, smlnum, ulp, unfl -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external caxpy, ccopy, cgemv, cscal, clacpy, clartg, - & cvout, claset, slabad, cmout, arscnd, ivout -c -c %--------------------% -c | External Functions | -c %--------------------% -c - Real - & clanhs, slamch, slapy2 - external clanhs, slamch, slapy2 -c -c %----------------------% -c | Intrinsics Functions | -c %----------------------% -c - intrinsic abs, aimag, conjg, cmplx, max, min, real -c -c %---------------------% -c | Statement Functions | -c %---------------------% -c - Real - & cabs1 - cabs1( cdum ) = abs( real( cdum ) ) + abs( aimag( cdum ) ) -c -c %----------------% -c | Data statments | -c %----------------% -c - data first / .true. / -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c - if (first) then -c -c %-----------------------------------------------% -c | Set machine-dependent constants for the | -c | stopping criterion. If norm(H) <= sqrt(OVFL), | -c | overflow should not occur. | -c | REFERENCE: LAPACK subroutine clahqr | -c %-----------------------------------------------% -c - unfl = slamch( 'safe minimum' ) - ovfl = real(one / unfl) - call slabad( unfl, ovfl ) - ulp = slamch( 'precision' ) - smlnum = unfl*( n / ulp ) - first = .false. - end if -c -c %-------------------------------% -c | Initialize timing statistics | -c | & message level for debugging | -c %-------------------------------% -c - call arscnd (t0) - msglvl = mcapps -c - kplusp = kev + np -c -c %--------------------------------------------% -c | Initialize Q to the identity to accumulate | -c | the rotations and reflections | -c %--------------------------------------------% -c - call claset ('All', kplusp, kplusp, zero, one, q, ldq) -c -c %----------------------------------------------% -c | Quick return if there are no shifts to apply | -c %----------------------------------------------% -c - if (np .eq. 0) go to 9000 -c -c %----------------------------------------------% -c | Chase the bulge with the application of each | -c | implicit shift. Each shift is applied to the | -c | whole matrix including each block. | -c %----------------------------------------------% -c - do 110 jj = 1, np - sigma = shift(jj) -c - if (msglvl .gt. 2 ) then - call ivout (logfil, 1, jj, ndigit, - & '_napps: shift number.') - call cvout (logfil, 1, sigma, ndigit, - & '_napps: Value of the shift ') - end if -c - istart = 1 - 20 continue -c - do 30 i = istart, kplusp-1 -c -c %----------------------------------------% -c | Check for splitting and deflation. Use | -c | a standard test as in the QR algorithm | -c | REFERENCE: LAPACK subroutine clahqr | -c %----------------------------------------% -c - tst1 = cabs1( h( i, i ) ) + cabs1( h( i+1, i+1 ) ) - if( tst1.eq.rzero ) - & tst1 = clanhs( '1', kplusp-jj+1, h, ldh, workl ) - if ( abs(real(h(i+1,i))) - & .le. max(ulp*tst1, smlnum) ) then - if (msglvl .gt. 0) then - call ivout (logfil, 1, i, ndigit, - & '_napps: matrix splitting at row/column no.') - call ivout (logfil, 1, jj, ndigit, - & '_napps: matrix splitting with shift number.') - call cvout (logfil, 1, h(i+1,i), ndigit, - & '_napps: off diagonal element.') - end if - iend = i - h(i+1,i) = zero - go to 40 - end if - 30 continue - iend = kplusp - 40 continue -c - if (msglvl .gt. 2) then - call ivout (logfil, 1, istart, ndigit, - & '_napps: Start of current block ') - call ivout (logfil, 1, iend, ndigit, - & '_napps: End of current block ') - end if -c -c %------------------------------------------------% -c | No reason to apply a shift to block of order 1 | -c | or if the current block starts after the point | -c | of compression since we'll discard this stuff | -c %------------------------------------------------% -c - if ( istart .eq. iend .or. istart .gt. kev) go to 100 -c - h11 = h(istart,istart) - h21 = h(istart+1,istart) - f = h11 - sigma - g = h21 -c - do 80 i = istart, iend-1 -c -c %------------------------------------------------------% -c | Construct the plane rotation G to zero out the bulge | -c %------------------------------------------------------% -c - call clartg (f, g, c, s, r) - if (i .gt. istart) then - h(i,i-1) = r - h(i+1,i-1) = zero - end if -c -c %---------------------------------------------% -c | Apply rotation to the left of H; H <- G'*H | -c %---------------------------------------------% -c - do 50 j = i, kplusp - t = c*h(i,j) + s*h(i+1,j) - h(i+1,j) = -conjg(s)*h(i,j) + c*h(i+1,j) - h(i,j) = t - 50 continue -c -c %---------------------------------------------% -c | Apply rotation to the right of H; H <- H*G | -c %---------------------------------------------% -c - do 60 j = 1, min(i+2,iend) - t = c*h(j,i) + conjg(s)*h(j,i+1) - h(j,i+1) = -s*h(j,i) + c*h(j,i+1) - h(j,i) = t - 60 continue -c -c %-----------------------------------------------------% -c | Accumulate the rotation in the matrix Q; Q <- Q*G' | -c %-----------------------------------------------------% -c - do 70 j = 1, min(i+jj, kplusp) - t = c*q(j,i) + conjg(s)*q(j,i+1) - q(j,i+1) = - s*q(j,i) + c*q(j,i+1) - q(j,i) = t - 70 continue -c -c %---------------------------% -c | Prepare for next rotation | -c %---------------------------% -c - if (i .lt. iend-1) then - f = h(i+1,i) - g = h(i+2,i) - end if - 80 continue -c -c %-------------------------------% -c | Finished applying the shift. | -c %-------------------------------% -c - 100 continue -c -c %---------------------------------------------------------% -c | Apply the same shift to the next block if there is any. | -c %---------------------------------------------------------% -c - istart = iend + 1 - if (iend .lt. kplusp) go to 20 -c -c %---------------------------------------------% -c | Loop back to the top to get the next shift. | -c %---------------------------------------------% -c - 110 continue -c -c %---------------------------------------------------% -c | Perform a similarity transformation that makes | -c | sure that the compressed H will have non-negative | -c | real subdiagonal elements. | -c %---------------------------------------------------% -c - do 120 j=1,kev - if ( real( h(j+1,j) ) .lt. rzero .or. - & aimag( h(j+1,j) ) .ne. rzero ) then - t = h(j+1,j) / slapy2(real(h(j+1,j)),aimag(h(j+1,j))) - call cscal( kplusp-j+1, conjg(t), h(j+1,j), ldh ) - call cscal( min(j+2, kplusp), t, h(1,j+1), 1 ) - call cscal( min(j+np+1,kplusp), t, q(1,j+1), 1 ) - h(j+1,j) = cmplx( real( h(j+1,j) ), rzero ) - end if - 120 continue -c - do 130 i = 1, kev -c -c %--------------------------------------------% -c | Final check for splitting and deflation. | -c | Use a standard test as in the QR algorithm | -c | REFERENCE: LAPACK subroutine clahqr. | -c | Note: Since the subdiagonals of the | -c | compressed H are nonnegative real numbers, | -c | we take advantage of this. | -c %--------------------------------------------% -c - tst1 = cabs1( h( i, i ) ) + cabs1( h( i+1, i+1 ) ) - if( tst1 .eq. rzero ) - & tst1 = clanhs( '1', kev, h, ldh, workl ) - if( real( h( i+1,i ) ) .le. max( ulp*tst1, smlnum ) ) - & h(i+1,i) = zero - 130 continue -c -c %-------------------------------------------------% -c | Compute the (kev+1)-st column of (V*Q) and | -c | temporarily store the result in WORKD(N+1:2*N). | -c | This is needed in the residual update since we | -c | cannot GUARANTEE that the corresponding entry | -c | of H would be zero as in exact arithmetic. | -c %-------------------------------------------------% -c - if ( real( h(kev+1,kev) ) .gt. rzero ) - & call cgemv ('N', n, kplusp, one, v, ldv, q(1,kev+1), 1, zero, - & workd(n+1), 1) -c -c %----------------------------------------------------------% -c | Compute column 1 to kev of (V*Q) in backward order | -c | taking advantage of the upper Hessenberg structure of Q. | -c %----------------------------------------------------------% -c - do 140 i = 1, kev - call cgemv ('N', n, kplusp-i+1, one, v, ldv, - & q(1,kev-i+1), 1, zero, workd, 1) - call ccopy (n, workd, 1, v(1,kplusp-i+1), 1) - 140 continue -c -c %-------------------------------------------------% -c | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). | -c %-------------------------------------------------% -c - call clacpy ('A', n, kev, v(1,kplusp-kev+1), ldv, v, ldv) -c -c %--------------------------------------------------------------% -c | Copy the (kev+1)-st column of (V*Q) in the appropriate place | -c %--------------------------------------------------------------% -c - if ( real( h(kev+1,kev) ) .gt. rzero ) - & call ccopy (n, workd(n+1), 1, v(1,kev+1), 1) -c -c %-------------------------------------% -c | Update the residual vector: | -c | r <- sigmak*r + betak*v(:,kev+1) | -c | where | -c | sigmak = (e_{kev+p}'*Q)*e_{kev} | -c | betak = e_{kev+1}'*H*e_{kev} | -c %-------------------------------------% -c - call cscal (n, q(kplusp,kev), resid, 1) - if ( real( h(kev+1,kev) ) .gt. rzero ) - & call caxpy (n, h(kev+1,kev), v(1,kev+1), 1, resid, 1) -c - if (msglvl .gt. 1) then - call cvout (logfil, 1, q(kplusp,kev), ndigit, - & '_napps: sigmak = (e_{kev+p}^T*Q)*e_{kev}') - call cvout (logfil, 1, h(kev+1,kev), ndigit, - & '_napps: betak = e_{kev+1}^T*H*e_{kev}') - call ivout (logfil, 1, kev, ndigit, - & '_napps: Order of the final Hessenberg matrix ') - if (msglvl .gt. 2) then - call cmout (logfil, kev, kev, h, ldh, ndigit, - & '_napps: updated Hessenberg matrix H for next iteration') - end if -c - end if -c - 9000 continue - call arscnd (t1) - tcapps = tcapps + (t1 - t0) -c - return -c -c %---------------% -c | End of cnapps | -c %---------------% -c - end
--- a/libcruft/arpack/src/cnaup2.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,801 +0,0 @@ -c\BeginDoc -c -c\Name: cnaup2 -c -c\Description: -c Intermediate level interface called by cnaupd. -c -c\Usage: -c call cnaup2 -c ( IDO, BMAT, N, WHICH, NEV, NP, TOL, RESID, MODE, IUPD, -c ISHIFT, MXITER, V, LDV, H, LDH, RITZ, BOUNDS, -c Q, LDQ, WORKL, IPNTR, WORKD, RWORK, INFO ) -c -c\Arguments -c -c IDO, BMAT, N, WHICH, NEV, TOL, RESID: same as defined in cnaupd. -c MODE, ISHIFT, MXITER: see the definition of IPARAM in cnaupd. -c -c NP Integer. (INPUT/OUTPUT) -c Contains the number of implicit shifts to apply during -c each Arnoldi iteration. -c If ISHIFT=1, NP is adjusted dynamically at each iteration -c to accelerate convergence and prevent stagnation. -c This is also roughly equal to the number of matrix-vector -c products (involving the operator OP) per Arnoldi iteration. -c The logic for adjusting is contained within the current -c subroutine. -c If ISHIFT=0, NP is the number of shifts the user needs -c to provide via reverse comunication. 0 < NP < NCV-NEV. -c NP may be less than NCV-NEV since a leading block of the current -c upper Hessenberg matrix has split off and contains "unwanted" -c Ritz values. -c Upon termination of the IRA iteration, NP contains the number -c of "converged" wanted Ritz values. -c -c IUPD Integer. (INPUT) -c IUPD .EQ. 0: use explicit restart instead implicit update. -c IUPD .NE. 0: use implicit update. -c -c V Complex N by (NEV+NP) array. (INPUT/OUTPUT) -c The Arnoldi basis vectors are returned in the first NEV -c columns of V. -c -c LDV Integer. (INPUT) -c Leading dimension of V exactly as declared in the calling -c program. -c -c H Complex (NEV+NP) by (NEV+NP) array. (OUTPUT) -c H is used to store the generated upper Hessenberg matrix -c -c LDH Integer. (INPUT) -c Leading dimension of H exactly as declared in the calling -c program. -c -c RITZ Complex array of length NEV+NP. (OUTPUT) -c RITZ(1:NEV) contains the computed Ritz values of OP. -c -c BOUNDS Complex array of length NEV+NP. (OUTPUT) -c BOUNDS(1:NEV) contain the error bounds corresponding to -c the computed Ritz values. -c -c Q Complex (NEV+NP) by (NEV+NP) array. (WORKSPACE) -c Private (replicated) work array used to accumulate the -c rotation in the shift application step. -c -c LDQ Integer. (INPUT) -c Leading dimension of Q exactly as declared in the calling -c program. -c -c WORKL Complex work array of length at least -c (NEV+NP)**2 + 3*(NEV+NP). (WORKSPACE) -c Private (replicated) array on each PE or array allocated on -c the front end. It is used in shifts calculation, shifts -c application and convergence checking. -c -c -c IPNTR Integer array of length 3. (OUTPUT) -c Pointer to mark the starting locations in the WORKD for -c vectors used by the Arnoldi iteration. -c ------------------------------------------------------------- -c IPNTR(1): pointer to the current operand vector X. -c IPNTR(2): pointer to the current result vector Y. -c IPNTR(3): pointer to the vector B * X when used in the -c shift-and-invert mode. X is the current operand. -c ------------------------------------------------------------- -c -c WORKD Complex work array of length 3*N. (WORKSPACE) -c Distributed array to be used in the basic Arnoldi iteration -c for reverse communication. The user should not use WORKD -c as temporary workspace during the iteration !!!!!!!!!! -c See Data Distribution Note in CNAUPD. -c -c RWORK Real work array of length NEV+NP ( WORKSPACE) -c Private (replicated) array on each PE or array allocated on -c the front end. -c -c INFO Integer. (INPUT/OUTPUT) -c If INFO .EQ. 0, a randomly initial residual vector is used. -c If INFO .NE. 0, RESID contains the initial residual vector, -c possibly from a previous run. -c Error flag on output. -c = 0: Normal return. -c = 1: Maximum number of iterations taken. -c All possible eigenvalues of OP has been found. -c NP returns the number of converged Ritz values. -c = 2: No shifts could be applied. -c = -8: Error return from LAPACK eigenvalue calculation; -c This should never happen. -c = -9: Starting vector is zero. -c = -9999: Could not build an Arnoldi factorization. -c Size that was built in returned in NP. -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Local variables: -c xxxxxx Complex -c -c\References: -c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in -c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), -c pp 357-385. -c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly -c Restarted Arnoldi Iteration", Rice University Technical Report -c TR95-13, Department of Computational and Applied Mathematics. -c -c\Routines called: -c cgetv0 ARPACK initial vector generation routine. -c cnaitr ARPACK Arnoldi factorization routine. -c cnapps ARPACK application of implicit shifts routine. -c cneigh ARPACK compute Ritz values and error bounds routine. -c cngets ARPACK reorder Ritz values and error bounds routine. -c csortc ARPACK sorting routine. -c ivout ARPACK utility routine that prints integers. -c arscnd ARPACK utility routine for timing. -c cmout ARPACK utility routine that prints matrices -c cvout ARPACK utility routine that prints vectors. -c svout ARPACK utility routine that prints vectors. -c slamch LAPACK routine that determines machine constants. -c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. -c ccopy Level 1 BLAS that copies one vector to another . -c cdotc Level 1 BLAS that computes the scalar product of two vectors. -c cswap Level 1 BLAS that swaps two vectors. -c scnrm2 Level 1 BLAS that computes the norm of a vector. -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice Universitya -c Chao Yang Houston, Texas -c Dept. of Computational & -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\SCCS Information: @(#) -c FILE: naup2.F SID: 2.6 DATE OF SID: 06/01/00 RELEASE: 2 -c -c\Remarks -c 1. None -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine cnaup2 - & ( ido, bmat, n, which, nev, np, tol, resid, mode, iupd, - & ishift, mxiter, v, ldv, h, ldh, ritz, bounds, - & q, ldq, workl, ipntr, workd, rwork, info ) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - character bmat*1, which*2 - integer ido, info, ishift, iupd, mode, ldh, ldq, ldv, mxiter, - & n, nev, np - Real - & tol -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - integer ipntr(13) - Complex - & bounds(nev+np), h(ldh,nev+np), q(ldq,nev+np), - & resid(n), ritz(nev+np), v(ldv,nev+np), - & workd(3*n), workl( (nev+np)*(nev+np+3) ) - Real - & rwork(nev+np) -c -c %------------% -c | Parameters | -c %------------% -c - Complex - & one, zero - Real - & rzero - parameter (one = (1.0E+0, 0.0E+0) , zero = (0.0E+0, 0.0E+0) , - & rzero = 0.0E+0 ) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - logical cnorm , getv0, initv , update, ushift - integer ierr , iter , kplusp, msglvl, nconv, - & nevbef, nev0 , np0 , nptemp, i , - & j - Complex - & cmpnorm - Real - & rnorm , eps23, rtemp - character wprime*2 -c - save cnorm, getv0, initv , update, ushift, - & rnorm, iter , kplusp, msglvl, nconv , - & nevbef, nev0 , np0 , eps23 -c -c -c %-----------------------% -c | Local array arguments | -c %-----------------------% -c - integer kp(3) -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external ccopy, cgetv0, cnaitr, cneigh, cngets, cnapps, - & csortc, cswap, cmout, cvout, ivout, arscnd -c -c %--------------------% -c | External functions | -c %--------------------% -c - Complex - & cdotc - Real - & scnrm2, slamch, slapy2 - external cdotc, scnrm2, slamch, slapy2 -c -c %---------------------% -c | Intrinsic Functions | -c %---------------------% -c - intrinsic aimag, real , min, max -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c - if (ido .eq. 0) then -c - call arscnd (t0) -c - msglvl = mcaup2 -c - nev0 = nev - np0 = np -c -c %-------------------------------------% -c | kplusp is the bound on the largest | -c | Lanczos factorization built. | -c | nconv is the current number of | -c | "converged" eigenvalues. | -c | iter is the counter on the current | -c | iteration step. | -c %-------------------------------------% -c - kplusp = nev + np - nconv = 0 - iter = 0 -c -c %---------------------------------% -c | Get machine dependent constant. | -c %---------------------------------% -c - eps23 = slamch('Epsilon-Machine') - eps23 = eps23**(2.0E+0 / 3.0E+0 ) -c -c %---------------------------------------% -c | Set flags for computing the first NEV | -c | steps of the Arnoldi factorization. | -c %---------------------------------------% -c - getv0 = .true. - update = .false. - ushift = .false. - cnorm = .false. -c - if (info .ne. 0) then -c -c %--------------------------------------------% -c | User provides the initial residual vector. | -c %--------------------------------------------% -c - initv = .true. - info = 0 - else - initv = .false. - end if - end if -c -c %---------------------------------------------% -c | Get a possibly random starting vector and | -c | force it into the range of the operator OP. | -c %---------------------------------------------% -c - 10 continue -c - if (getv0) then - call cgetv0 (ido, bmat, 1, initv, n, 1, v, ldv, resid, rnorm, - & ipntr, workd, info) -c - if (ido .ne. 99) go to 9000 -c - if (rnorm .eq. rzero) then -c -c %-----------------------------------------% -c | The initial vector is zero. Error exit. | -c %-----------------------------------------% -c - info = -9 - go to 1100 - end if - getv0 = .false. - ido = 0 - end if -c -c %-----------------------------------% -c | Back from reverse communication : | -c | continue with update step | -c %-----------------------------------% -c - if (update) go to 20 -c -c %-------------------------------------------% -c | Back from computing user specified shifts | -c %-------------------------------------------% -c - if (ushift) go to 50 -c -c %-------------------------------------% -c | Back from computing residual norm | -c | at the end of the current iteration | -c %-------------------------------------% -c - if (cnorm) go to 100 -c -c %----------------------------------------------------------% -c | Compute the first NEV steps of the Arnoldi factorization | -c %----------------------------------------------------------% -c - call cnaitr (ido, bmat, n, 0, nev, mode, resid, rnorm, v, ldv, - & h, ldh, ipntr, workd, info) -c - if (ido .ne. 99) go to 9000 -c - if (info .gt. 0) then - np = info - mxiter = iter - info = -9999 - go to 1200 - end if -c -c %--------------------------------------------------------------% -c | | -c | M A I N ARNOLDI I T E R A T I O N L O O P | -c | Each iteration implicitly restarts the Arnoldi | -c | factorization in place. | -c | | -c %--------------------------------------------------------------% -c - 1000 continue -c - iter = iter + 1 -c - if (msglvl .gt. 0) then - call ivout (logfil, 1, iter, ndigit, - & '_naup2: **** Start of major iteration number ****') - end if -c -c %-----------------------------------------------------------% -c | Compute NP additional steps of the Arnoldi factorization. | -c | Adjust NP since NEV might have been updated by last call | -c | to the shift application routine cnapps. | -c %-----------------------------------------------------------% -c - np = kplusp - nev -c - if (msglvl .gt. 1) then - call ivout (logfil, 1, nev, ndigit, - & '_naup2: The length of the current Arnoldi factorization') - call ivout (logfil, 1, np, ndigit, - & '_naup2: Extend the Arnoldi factorization by') - end if -c -c %-----------------------------------------------------------% -c | Compute NP additional steps of the Arnoldi factorization. | -c %-----------------------------------------------------------% -c - ido = 0 - 20 continue - update = .true. -c - call cnaitr(ido, bmat, n, nev, np, mode, resid, rnorm, - & v , ldv , h, ldh, ipntr, workd, info) -c - if (ido .ne. 99) go to 9000 -c - if (info .gt. 0) then - np = info - mxiter = iter - info = -9999 - go to 1200 - end if - update = .false. -c - if (msglvl .gt. 1) then - call svout (logfil, 1, rnorm, ndigit, - & '_naup2: Corresponding B-norm of the residual') - end if -c -c %--------------------------------------------------------% -c | Compute the eigenvalues and corresponding error bounds | -c | of the current upper Hessenberg matrix. | -c %--------------------------------------------------------% -c - call cneigh (rnorm, kplusp, h, ldh, ritz, bounds, - & q, ldq, workl, rwork, ierr) -c - if (ierr .ne. 0) then - info = -8 - go to 1200 - end if -c -c %---------------------------------------------------% -c | Select the wanted Ritz values and their bounds | -c | to be used in the convergence test. | -c | The wanted part of the spectrum and corresponding | -c | error bounds are in the last NEV loc. of RITZ, | -c | and BOUNDS respectively. | -c %---------------------------------------------------% -c - nev = nev0 - np = np0 -c -c %--------------------------------------------------% -c | Make a copy of Ritz values and the corresponding | -c | Ritz estimates obtained from cneigh. | -c %--------------------------------------------------% -c - call ccopy(kplusp,ritz,1,workl(kplusp**2+1),1) - call ccopy(kplusp,bounds,1,workl(kplusp**2+kplusp+1),1) -c -c %---------------------------------------------------% -c | Select the wanted Ritz values and their bounds | -c | to be used in the convergence test. | -c | The wanted part of the spectrum and corresponding | -c | bounds are in the last NEV loc. of RITZ | -c | BOUNDS respectively. | -c %---------------------------------------------------% -c - call cngets (ishift, which, nev, np, ritz, bounds) -c -c %------------------------------------------------------------% -c | Convergence test: currently we use the following criteria. | -c | The relative accuracy of a Ritz value is considered | -c | acceptable if: | -c | | -c | error_bounds(i) .le. tol*max(eps23, magnitude_of_ritz(i)). | -c | | -c %------------------------------------------------------------% -c - nconv = 0 -c - do 25 i = 1, nev - rtemp = max( eps23, slapy2( real (ritz(np+i)), - & aimag(ritz(np+i)) ) ) - if ( slapy2(real (bounds(np+i)),aimag(bounds(np+i))) - & .le. tol*rtemp ) then - nconv = nconv + 1 - end if - 25 continue -c - if (msglvl .gt. 2) then - kp(1) = nev - kp(2) = np - kp(3) = nconv - call ivout (logfil, 3, kp, ndigit, - & '_naup2: NEV, NP, NCONV are') - call cvout (logfil, kplusp, ritz, ndigit, - & '_naup2: The eigenvalues of H') - call cvout (logfil, kplusp, bounds, ndigit, - & '_naup2: Ritz estimates of the current NCV Ritz values') - end if -c -c %---------------------------------------------------------% -c | Count the number of unwanted Ritz values that have zero | -c | Ritz estimates. If any Ritz estimates are equal to zero | -c | then a leading block of H of order equal to at least | -c | the number of Ritz values with zero Ritz estimates has | -c | split off. None of these Ritz values may be removed by | -c | shifting. Decrease NP the number of shifts to apply. If | -c | no shifts may be applied, then prepare to exit | -c %---------------------------------------------------------% -c - nptemp = np - do 30 j=1, nptemp - if (bounds(j) .eq. zero) then - np = np - 1 - nev = nev + 1 - end if - 30 continue -c - if ( (nconv .ge. nev0) .or. - & (iter .gt. mxiter) .or. - & (np .eq. 0) ) then -c - if (msglvl .gt. 4) then - call cvout(logfil, kplusp, workl(kplusp**2+1), ndigit, - & '_naup2: Eigenvalues computed by _neigh:') - call cvout(logfil, kplusp, workl(kplusp**2+kplusp+1), - & ndigit, - & '_naup2: Ritz estimates computed by _neigh:') - end if -c -c %------------------------------------------------% -c | Prepare to exit. Put the converged Ritz values | -c | and corresponding bounds in RITZ(1:NCONV) and | -c | BOUNDS(1:NCONV) respectively. Then sort. Be | -c | careful when NCONV > NP | -c %------------------------------------------------% -c -c %------------------------------------------% -c | Use h( 3,1 ) as storage to communicate | -c | rnorm to cneupd if needed | -c %------------------------------------------% - - h(3,1) = cmplx(rnorm,rzero) -c -c %----------------------------------------------% -c | Sort Ritz values so that converged Ritz | -c | values appear within the first NEV locations | -c | of ritz and bounds, and the most desired one | -c | appears at the front. | -c %----------------------------------------------% -c - if (which .eq. 'LM') wprime = 'SM' - if (which .eq. 'SM') wprime = 'LM' - if (which .eq. 'LR') wprime = 'SR' - if (which .eq. 'SR') wprime = 'LR' - if (which .eq. 'LI') wprime = 'SI' - if (which .eq. 'SI') wprime = 'LI' -c - call csortc(wprime, .true., kplusp, ritz, bounds) -c -c %--------------------------------------------------% -c | Scale the Ritz estimate of each Ritz value | -c | by 1 / max(eps23, magnitude of the Ritz value). | -c %--------------------------------------------------% -c - do 35 j = 1, nev0 - rtemp = max( eps23, slapy2( real (ritz(j)), - & aimag(ritz(j)) ) ) - bounds(j) = bounds(j)/rtemp - 35 continue -c -c %---------------------------------------------------% -c | Sort the Ritz values according to the scaled Ritz | -c | estimates. This will push all the converged ones | -c | towards the front of ritz, bounds (in the case | -c | when NCONV < NEV.) | -c %---------------------------------------------------% -c - wprime = 'LM' - call csortc(wprime, .true., nev0, bounds, ritz) -c -c %----------------------------------------------% -c | Scale the Ritz estimate back to its original | -c | value. | -c %----------------------------------------------% -c - do 40 j = 1, nev0 - rtemp = max( eps23, slapy2( real (ritz(j)), - & aimag(ritz(j)) ) ) - bounds(j) = bounds(j)*rtemp - 40 continue -c -c %-----------------------------------------------% -c | Sort the converged Ritz values again so that | -c | the "threshold" value appears at the front of | -c | ritz and bound. | -c %-----------------------------------------------% -c - call csortc(which, .true., nconv, ritz, bounds) -c - if (msglvl .gt. 1) then - call cvout (logfil, kplusp, ritz, ndigit, - & '_naup2: Sorted eigenvalues') - call cvout (logfil, kplusp, bounds, ndigit, - & '_naup2: Sorted ritz estimates.') - end if -c -c %------------------------------------% -c | Max iterations have been exceeded. | -c %------------------------------------% -c - if (iter .gt. mxiter .and. nconv .lt. nev0) info = 1 -c -c %---------------------% -c | No shifts to apply. | -c %---------------------% -c - if (np .eq. 0 .and. nconv .lt. nev0) info = 2 -c - np = nconv - go to 1100 -c - else if ( (nconv .lt. nev0) .and. (ishift .eq. 1) ) then -c -c %-------------------------------------------------% -c | Do not have all the requested eigenvalues yet. | -c | To prevent possible stagnation, adjust the size | -c | of NEV. | -c %-------------------------------------------------% -c - nevbef = nev - nev = nev + min(nconv, np/2) - if (nev .eq. 1 .and. kplusp .ge. 6) then - nev = kplusp / 2 - else if (nev .eq. 1 .and. kplusp .gt. 3) then - nev = 2 - end if - np = kplusp - nev -c -c %---------------------------------------% -c | If the size of NEV was just increased | -c | resort the eigenvalues. | -c %---------------------------------------% -c - if (nevbef .lt. nev) - & call cngets (ishift, which, nev, np, ritz, bounds) -c - end if -c - if (msglvl .gt. 0) then - call ivout (logfil, 1, nconv, ndigit, - & '_naup2: no. of "converged" Ritz values at this iter.') - if (msglvl .gt. 1) then - kp(1) = nev - kp(2) = np - call ivout (logfil, 2, kp, ndigit, - & '_naup2: NEV and NP are') - call cvout (logfil, nev, ritz(np+1), ndigit, - & '_naup2: "wanted" Ritz values ') - call cvout (logfil, nev, bounds(np+1), ndigit, - & '_naup2: Ritz estimates of the "wanted" values ') - end if - end if -c - if (ishift .eq. 0) then -c -c %-------------------------------------------------------% -c | User specified shifts: pop back out to get the shifts | -c | and return them in the first 2*NP locations of WORKL. | -c %-------------------------------------------------------% -c - ushift = .true. - ido = 3 - go to 9000 - end if - 50 continue - ushift = .false. -c - if ( ishift .ne. 1 ) then -c -c %----------------------------------% -c | Move the NP shifts from WORKL to | -c | RITZ, to free up WORKL | -c | for non-exact shift case. | -c %----------------------------------% -c - call ccopy (np, workl, 1, ritz, 1) - end if -c - if (msglvl .gt. 2) then - call ivout (logfil, 1, np, ndigit, - & '_naup2: The number of shifts to apply ') - call cvout (logfil, np, ritz, ndigit, - & '_naup2: values of the shifts') - if ( ishift .eq. 1 ) - & call cvout (logfil, np, bounds, ndigit, - & '_naup2: Ritz estimates of the shifts') - end if -c -c %---------------------------------------------------------% -c | Apply the NP implicit shifts by QR bulge chasing. | -c | Each shift is applied to the whole upper Hessenberg | -c | matrix H. | -c | The first 2*N locations of WORKD are used as workspace. | -c %---------------------------------------------------------% -c - call cnapps (n, nev, np, ritz, v, ldv, - & h, ldh, resid, q, ldq, workl, workd) -c -c %---------------------------------------------% -c | Compute the B-norm of the updated residual. | -c | Keep B*RESID in WORKD(1:N) to be used in | -c | the first step of the next call to cnaitr. | -c %---------------------------------------------% -c - cnorm = .true. - call arscnd (t2) - if (bmat .eq. 'G') then - nbx = nbx + 1 - call ccopy (n, resid, 1, workd(n+1), 1) - ipntr(1) = n + 1 - ipntr(2) = 1 - ido = 2 -c -c %----------------------------------% -c | Exit in order to compute B*RESID | -c %----------------------------------% -c - go to 9000 - else if (bmat .eq. 'I') then - call ccopy (n, resid, 1, workd, 1) - end if -c - 100 continue -c -c %----------------------------------% -c | Back from reverse communication; | -c | WORKD(1:N) := B*RESID | -c %----------------------------------% -c - if (bmat .eq. 'G') then - call arscnd (t3) - tmvbx = tmvbx + (t3 - t2) - end if -c - if (bmat .eq. 'G') then - cmpnorm = cdotc (n, resid, 1, workd, 1) - rnorm = sqrt(slapy2(real (cmpnorm),aimag(cmpnorm))) - else if (bmat .eq. 'I') then - rnorm = scnrm2(n, resid, 1) - end if - cnorm = .false. -c - if (msglvl .gt. 2) then - call svout (logfil, 1, rnorm, ndigit, - & '_naup2: B-norm of residual for compressed factorization') - call cmout (logfil, nev, nev, h, ldh, ndigit, - & '_naup2: Compressed upper Hessenberg matrix H') - end if -c - go to 1000 -c -c %---------------------------------------------------------------% -c | | -c | E N D O F M A I N I T E R A T I O N L O O P | -c | | -c %---------------------------------------------------------------% -c - 1100 continue -c - mxiter = iter - nev = nconv -c - 1200 continue - ido = 99 -c -c %------------% -c | Error Exit | -c %------------% -c - call arscnd (t1) - tcaup2 = t1 - t0 -c - 9000 continue -c -c %---------------% -c | End of cnaup2 | -c %---------------% -c - return - end
--- a/libcruft/arpack/src/cnaupd.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,664 +0,0 @@ -c\BeginDoc -c -c\Name: cnaupd -c -c\Description: -c Reverse communication interface for the Implicitly Restarted Arnoldi -c iteration. This is intended to be used to find a few eigenpairs of a -c complex linear operator OP with respect to a semi-inner product defined -c by a hermitian positive semi-definite real matrix B. B may be the identity -c matrix. NOTE: if both OP and B are real, then ssaupd or snaupd should -c be used. -c -c -c The computed approximate eigenvalues are called Ritz values and -c the corresponding approximate eigenvectors are called Ritz vectors. -c -c cnaupd is usually called iteratively to solve one of the -c following problems: -c -c Mode 1: A*x = lambda*x. -c ===> OP = A and B = I. -c -c Mode 2: A*x = lambda*M*x, M hermitian positive definite -c ===> OP = inv[M]*A and B = M. -c ===> (If M can be factored see remark 3 below) -c -c Mode 3: A*x = lambda*M*x, M hermitian semi-definite -c ===> OP = inv[A - sigma*M]*M and B = M. -c ===> shift-and-invert mode -c If OP*x = amu*x, then lambda = sigma + 1/amu. -c -c -c NOTE: The action of w <- inv[A - sigma*M]*v or w <- inv[M]*v -c should be accomplished either by a direct method -c using a sparse matrix factorization and solving -c -c [A - sigma*M]*w = v or M*w = v, -c -c or through an iterative method for solving these -c systems. If an iterative method is used, the -c convergence test must be more stringent than -c the accuracy requirements for the eigenvalue -c approximations. -c -c\Usage: -c call cnaupd -c ( IDO, BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, -c IPNTR, WORKD, WORKL, LWORKL, RWORK, INFO ) -c -c\Arguments -c IDO Integer. (INPUT/OUTPUT) -c Reverse communication flag. IDO must be zero on the first -c call to cnaupd. IDO will be set internally to -c indicate the type of operation to be performed. Control is -c then given back to the calling routine which has the -c responsibility to carry out the requested operation and call -c cnaupd with the result. The operand is given in -c WORKD(IPNTR(1)), the result must be put in WORKD(IPNTR(2)). -c ------------------------------------------------------------- -c IDO = 0: first call to the reverse communication interface -c IDO = -1: compute Y = OP * X where -c IPNTR(1) is the pointer into WORKD for X, -c IPNTR(2) is the pointer into WORKD for Y. -c This is for the initialization phase to force the -c starting vector into the range of OP. -c IDO = 1: compute Y = OP * X where -c IPNTR(1) is the pointer into WORKD for X, -c IPNTR(2) is the pointer into WORKD for Y. -c In mode 3, the vector B * X is already -c available in WORKD(ipntr(3)). It does not -c need to be recomputed in forming OP * X. -c IDO = 2: compute Y = M * X where -c IPNTR(1) is the pointer into WORKD for X, -c IPNTR(2) is the pointer into WORKD for Y. -c IDO = 3: compute and return the shifts in the first -c NP locations of WORKL. -c IDO = 99: done -c ------------------------------------------------------------- -c After the initialization phase, when the routine is used in -c the "shift-and-invert" mode, the vector M * X is already -c available and does not need to be recomputed in forming OP*X. -c -c BMAT Character*1. (INPUT) -c BMAT specifies the type of the matrix B that defines the -c semi-inner product for the operator OP. -c BMAT = 'I' -> standard eigenvalue problem A*x = lambda*x -c BMAT = 'G' -> generalized eigenvalue problem A*x = lambda*M*x -c -c N Integer. (INPUT) -c Dimension of the eigenproblem. -c -c WHICH Character*2. (INPUT) -c 'LM' -> want the NEV eigenvalues of largest magnitude. -c 'SM' -> want the NEV eigenvalues of smallest magnitude. -c 'LR' -> want the NEV eigenvalues of largest real part. -c 'SR' -> want the NEV eigenvalues of smallest real part. -c 'LI' -> want the NEV eigenvalues of largest imaginary part. -c 'SI' -> want the NEV eigenvalues of smallest imaginary part. -c -c NEV Integer. (INPUT) -c Number of eigenvalues of OP to be computed. 0 < NEV < N-1. -c -c TOL Real scalar. (INPUT) -c Stopping criteria: the relative accuracy of the Ritz value -c is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I)) -c where ABS(RITZ(I)) is the magnitude when RITZ(I) is complex. -c DEFAULT = slamch('EPS') (machine precision as computed -c by the LAPACK auxiliary subroutine slamch). -c -c RESID Complex array of length N. (INPUT/OUTPUT) -c On INPUT: -c If INFO .EQ. 0, a random initial residual vector is used. -c If INFO .NE. 0, RESID contains the initial residual vector, -c possibly from a previous run. -c On OUTPUT: -c RESID contains the final residual vector. -c -c NCV Integer. (INPUT) -c Number of columns of the matrix V. NCV must satisfy the two -c inequalities 1 <= NCV-NEV and NCV <= N. -c This will indicate how many Arnoldi vectors are generated -c at each iteration. After the startup phase in which NEV -c Arnoldi vectors are generated, the algorithm generates -c approximately NCV-NEV Arnoldi vectors at each subsequent update -c iteration. Most of the cost in generating each Arnoldi vector is -c in the matrix-vector operation OP*x. (See remark 4 below.) -c -c V Complex array N by NCV. (OUTPUT) -c Contains the final set of Arnoldi basis vectors. -c -c LDV Integer. (INPUT) -c Leading dimension of V exactly as declared in the calling program. -c -c IPARAM Integer array of length 11. (INPUT/OUTPUT) -c IPARAM(1) = ISHIFT: method for selecting the implicit shifts. -c The shifts selected at each iteration are used to filter out -c the components of the unwanted eigenvector. -c ------------------------------------------------------------- -c ISHIFT = 0: the shifts are to be provided by the user via -c reverse communication. The NCV eigenvalues of -c the Hessenberg matrix H are returned in the part -c of WORKL array corresponding to RITZ. -c ISHIFT = 1: exact shifts with respect to the current -c Hessenberg matrix H. This is equivalent to -c restarting the iteration from the beginning -c after updating the starting vector with a linear -c combination of Ritz vectors associated with the -c "wanted" eigenvalues. -c ISHIFT = 2: other choice of internal shift to be defined. -c ------------------------------------------------------------- -c -c IPARAM(2) = No longer referenced -c -c IPARAM(3) = MXITER -c On INPUT: maximum number of Arnoldi update iterations allowed. -c On OUTPUT: actual number of Arnoldi update iterations taken. -c -c IPARAM(4) = NB: blocksize to be used in the recurrence. -c The code currently works only for NB = 1. -c -c IPARAM(5) = NCONV: number of "converged" Ritz values. -c This represents the number of Ritz values that satisfy -c the convergence criterion. -c -c IPARAM(6) = IUPD -c No longer referenced. Implicit restarting is ALWAYS used. -c -c IPARAM(7) = MODE -c On INPUT determines what type of eigenproblem is being solved. -c Must be 1,2,3; See under \Description of cnaupd for the -c four modes available. -c -c IPARAM(8) = NP -c When ido = 3 and the user provides shifts through reverse -c communication (IPARAM(1)=0), _naupd returns NP, the number -c of shifts the user is to provide. 0 < NP < NCV-NEV. -c -c IPARAM(9) = NUMOP, IPARAM(10) = NUMOPB, IPARAM(11) = NUMREO, -c OUTPUT: NUMOP = total number of OP*x operations, -c NUMOPB = total number of B*x operations if BMAT='G', -c NUMREO = total number of steps of re-orthogonalization. -c -c IPNTR Integer array of length 14. (OUTPUT) -c Pointer to mark the starting locations in the WORKD and WORKL -c arrays for matrices/vectors used by the Arnoldi iteration. -c ------------------------------------------------------------- -c IPNTR(1): pointer to the current operand vector X in WORKD. -c IPNTR(2): pointer to the current result vector Y in WORKD. -c IPNTR(3): pointer to the vector B * X in WORKD when used in -c the shift-and-invert mode. -c IPNTR(4): pointer to the next available location in WORKL -c that is untouched by the program. -c IPNTR(5): pointer to the NCV by NCV upper Hessenberg -c matrix H in WORKL. -c IPNTR(6): pointer to the ritz value array RITZ -c IPNTR(7): pointer to the (projected) ritz vector array Q -c IPNTR(8): pointer to the error BOUNDS array in WORKL. -c IPNTR(14): pointer to the NP shifts in WORKL. See Remark 5 below. -c -c Note: IPNTR(9:13) is only referenced by cneupd. See Remark 2 below. -c -c IPNTR(9): pointer to the NCV RITZ values of the -c original system. -c IPNTR(10): Not Used -c IPNTR(11): pointer to the NCV corresponding error bounds. -c IPNTR(12): pointer to the NCV by NCV upper triangular -c Schur matrix for H. -c IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors -c of the upper Hessenberg matrix H. Only referenced by -c cneupd if RVEC = .TRUE. See Remark 2 below. -c -c ------------------------------------------------------------- -c -c WORKD Complex work array of length 3*N. (REVERSE COMMUNICATION) -c Distributed array to be used in the basic Arnoldi iteration -c for reverse communication. The user should not use WORKD -c as temporary workspace during the iteration !!!!!!!!!! -c See Data Distribution Note below. -c -c WORKL Complex work array of length LWORKL. (OUTPUT/WORKSPACE) -c Private (replicated) array on each PE or array allocated on -c the front end. See Data Distribution Note below. -c -c LWORKL Integer. (INPUT) -c LWORKL must be at least 3*NCV**2 + 5*NCV. -c -c RWORK Real work array of length NCV (WORKSPACE) -c Private (replicated) array on each PE or array allocated on -c the front end. -c -c -c INFO Integer. (INPUT/OUTPUT) -c If INFO .EQ. 0, a randomly initial residual vector is used. -c If INFO .NE. 0, RESID contains the initial residual vector, -c possibly from a previous run. -c Error flag on output. -c = 0: Normal exit. -c = 1: Maximum number of iterations taken. -c All possible eigenvalues of OP has been found. IPARAM(5) -c returns the number of wanted converged Ritz values. -c = 2: No longer an informational error. Deprecated starting -c with release 2 of ARPACK. -c = 3: No shifts could be applied during a cycle of the -c Implicitly restarted Arnoldi iteration. One possibility -c is to increase the size of NCV relative to NEV. -c See remark 4 below. -c = -1: N must be positive. -c = -2: NEV must be positive. -c = -3: NCV-NEV >= 2 and less than or equal to N. -c = -4: The maximum number of Arnoldi update iteration -c must be greater than zero. -c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI' -c = -6: BMAT must be one of 'I' or 'G'. -c = -7: Length of private work array is not sufficient. -c = -8: Error return from LAPACK eigenvalue calculation; -c = -9: Starting vector is zero. -c = -10: IPARAM(7) must be 1,2,3. -c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. -c = -12: IPARAM(1) must be equal to 0 or 1. -c = -9999: Could not build an Arnoldi factorization. -c User input error highly likely. Please -c check actual array dimensions and layout. -c IPARAM(5) returns the size of the current Arnoldi -c factorization. -c -c\Remarks -c 1. The computed Ritz values are approximate eigenvalues of OP. The -c selection of WHICH should be made with this in mind when using -c Mode = 3. When operating in Mode = 3 setting WHICH = 'LM' will -c compute the NEV eigenvalues of the original problem that are -c closest to the shift SIGMA . After convergence, approximate eigenvalues -c of the original problem may be obtained with the ARPACK subroutine cneupd. -c -c 2. If a basis for the invariant subspace corresponding to the converged Ritz -c values is needed, the user must call cneupd immediately following -c completion of cnaupd. This is new starting with release 2 of ARPACK. -c -c 3. If M can be factored into a Cholesky factorization M = LL` -c then Mode = 2 should not be selected. Instead one should use -c Mode = 1 with OP = inv(L)*A*inv(L`). Appropriate triangular -c linear systems should be solved with L and L` rather -c than computing inverses. After convergence, an approximate -c eigenvector z of the original problem is recovered by solving -c L`z = x where x is a Ritz vector of OP. -c -c 4. At present there is no a-priori analysis to guide the selection -c of NCV relative to NEV. The only formal requirement is that NCV > NEV + 1. -c However, it is recommended that NCV .ge. 2*NEV. If many problems of -c the same type are to be solved, one should experiment with increasing -c NCV while keeping NEV fixed for a given test problem. This will -c usually decrease the required number of OP*x operations but it -c also increases the work and storage required to maintain the orthogonal -c basis vectors. The optimal "cross-over" with respect to CPU time -c is problem dependent and must be determined empirically. -c See Chapter 8 of Reference 2 for further information. -c -c 5. When IPARAM(1) = 0, and IDO = 3, the user needs to provide the -c NP = IPARAM(8) complex shifts in locations -c WORKL(IPNTR(14)), WORKL(IPNTR(14)+1), ... , WORKL(IPNTR(14)+NP). -c Eigenvalues of the current upper Hessenberg matrix are located in -c WORKL(IPNTR(6)) through WORKL(IPNTR(6)+NCV-1). They are ordered -c according to the order defined by WHICH. The associated Ritz estimates -c are located in WORKL(IPNTR(8)), WORKL(IPNTR(8)+1), ... , -c WORKL(IPNTR(8)+NCV-1). -c -c----------------------------------------------------------------------- -c -c\Data Distribution Note: -c -c Fortran-D syntax: -c ================ -c Complex resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) -c decompose d1(n), d2(n,ncv) -c align resid(i) with d1(i) -c align v(i,j) with d2(i,j) -c align workd(i) with d1(i) range (1:n) -c align workd(i) with d1(i-n) range (n+1:2*n) -c align workd(i) with d1(i-2*n) range (2*n+1:3*n) -c distribute d1(block), d2(block,:) -c replicated workl(lworkl) -c -c Cray MPP syntax: -c =============== -c Complex resid(n), v(ldv,ncv), workd(n,3), workl(lworkl) -c shared resid(block), v(block,:), workd(block,:) -c replicated workl(lworkl) -c -c CM2/CM5 syntax: -c ============== -c -c----------------------------------------------------------------------- -c -c include 'ex-nonsym.doc' -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Local variables: -c xxxxxx Complex -c -c\References: -c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in -c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), -c pp 357-385. -c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly -c Restarted Arnoldi Iteration", Rice University Technical Report -c TR95-13, Department of Computational and Applied Mathematics. -c 3. B.N. Parlett & Y. Saad, "_Complex_ Shift and Invert Strategies for -c _Real_ Matrices", Linear Algebra and its Applications, vol 88/89, -c pp 575-595, (1987). -c -c\Routines called: -c cnaup2 ARPACK routine that implements the Implicitly Restarted -c Arnoldi Iteration. -c cstatn ARPACK routine that initializes the timing variables. -c ivout ARPACK utility routine that prints integers. -c cvout ARPACK utility routine that prints vectors. -c arscnd ARPACK utility routine for timing. -c slamch LAPACK routine that determines machine constants. -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\SCCS Information: @(#) -c FILE: naupd.F SID: 2.8 DATE OF SID: 04/10/01 RELEASE: 2 -c -c\Remarks -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine cnaupd - & ( ido, bmat, n, which, nev, tol, resid, ncv, v, ldv, iparam, - & ipntr, workd, workl, lworkl, rwork, info ) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - character bmat*1, which*2 - integer ido, info, ldv, lworkl, n, ncv, nev - Real - & tol -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - integer iparam(11), ipntr(14) - Complex - & resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) - Real - & rwork(ncv) -c -c %------------% -c | Parameters | -c %------------% -c - Complex - & one, zero - parameter (one = (1.0E+0, 0.0E+0) , zero = (0.0E+0, 0.0E+0) ) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - integer bounds, ierr, ih, iq, ishift, iupd, iw, - & ldh, ldq, levec, mode, msglvl, mxiter, nb, - & nev0, next, np, ritz, j - save bounds, ih, iq, ishift, iupd, iw, - & ldh, ldq, levec, mode, msglvl, mxiter, nb, - & nev0, next, np, ritz -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external cnaup2, cvout, ivout, arscnd, cstatn -c -c %--------------------% -c | External Functions | -c %--------------------% -c - Real - & slamch - external slamch -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c - if (ido .eq. 0) then -c -c %-------------------------------% -c | Initialize timing statistics | -c | & message level for debugging | -c %-------------------------------% -c - call cstatn - call arscnd (t0) - msglvl = mcaupd -c -c %----------------% -c | Error checking | -c %----------------% -c - ierr = 0 - ishift = iparam(1) -c levec = iparam(2) - mxiter = iparam(3) -c nb = iparam(4) - nb = 1 -c -c %--------------------------------------------% -c | Revision 2 performs only implicit restart. | -c %--------------------------------------------% -c - iupd = 1 - mode = iparam(7) -c - if (n .le. 0) then - ierr = -1 - else if (nev .le. 0) then - ierr = -2 - else if (ncv .le. nev .or. ncv .gt. n) then - ierr = -3 - else if (mxiter .le. 0) then - ierr = -4 - else if (which .ne. 'LM' .and. - & which .ne. 'SM' .and. - & which .ne. 'LR' .and. - & which .ne. 'SR' .and. - & which .ne. 'LI' .and. - & which .ne. 'SI') then - ierr = -5 - else if (bmat .ne. 'I' .and. bmat .ne. 'G') then - ierr = -6 - else if (lworkl .lt. 3*ncv**2 + 5*ncv) then - ierr = -7 - else if (mode .lt. 1 .or. mode .gt. 3) then - ierr = -10 - else if (mode .eq. 1 .and. bmat .eq. 'G') then - ierr = -11 - end if -c -c %------------% -c | Error Exit | -c %------------% -c - if (ierr .ne. 0) then - info = ierr - ido = 99 - go to 9000 - end if -c -c %------------------------% -c | Set default parameters | -c %------------------------% -c - if (nb .le. 0) nb = 1 - if (tol .le. 0.0E+0 ) tol = slamch('EpsMach') - if (ishift .ne. 0 .and. - & ishift .ne. 1 .and. - & ishift .ne. 2) ishift = 1 -c -c %----------------------------------------------% -c | NP is the number of additional steps to | -c | extend the length NEV Lanczos factorization. | -c | NEV0 is the local variable designating the | -c | size of the invariant subspace desired. | -c %----------------------------------------------% -c - np = ncv - nev - nev0 = nev -c -c %-----------------------------% -c | Zero out internal workspace | -c %-----------------------------% -c - do 10 j = 1, 3*ncv**2 + 5*ncv - workl(j) = zero - 10 continue -c -c %-------------------------------------------------------------% -c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | -c | etc... and the remaining workspace. | -c | Also update pointer to be used on output. | -c | Memory is laid out as follows: | -c | workl(1:ncv*ncv) := generated Hessenberg matrix | -c | workl(ncv*ncv+1:ncv*ncv+ncv) := the ritz values | -c | workl(ncv*ncv+ncv+1:ncv*ncv+2*ncv) := error bounds | -c | workl(ncv*ncv+2*ncv+1:2*ncv*ncv+2*ncv) := rotation matrix Q | -c | workl(2*ncv*ncv+2*ncv+1:3*ncv*ncv+5*ncv) := workspace | -c | The final workspace is needed by subroutine cneigh called | -c | by cnaup2. Subroutine cneigh calls LAPACK routines for | -c | calculating eigenvalues and the last row of the eigenvector | -c | matrix. | -c %-------------------------------------------------------------% -c - ldh = ncv - ldq = ncv - ih = 1 - ritz = ih + ldh*ncv - bounds = ritz + ncv - iq = bounds + ncv - iw = iq + ldq*ncv - next = iw + ncv**2 + 3*ncv -c - ipntr(4) = next - ipntr(5) = ih - ipntr(6) = ritz - ipntr(7) = iq - ipntr(8) = bounds - ipntr(14) = iw - end if -c -c %-------------------------------------------------------% -c | Carry out the Implicitly restarted Arnoldi Iteration. | -c %-------------------------------------------------------% -c - call cnaup2 - & ( ido, bmat, n, which, nev0, np, tol, resid, mode, iupd, - & ishift, mxiter, v, ldv, workl(ih), ldh, workl(ritz), - & workl(bounds), workl(iq), ldq, workl(iw), - & ipntr, workd, rwork, info ) -c -c %--------------------------------------------------% -c | ido .ne. 99 implies use of reverse communication | -c | to compute operations involving OP. | -c %--------------------------------------------------% -c - if (ido .eq. 3) iparam(8) = np - if (ido .ne. 99) go to 9000 -c - iparam(3) = mxiter - iparam(5) = np - iparam(9) = nopx - iparam(10) = nbx - iparam(11) = nrorth -c -c %------------------------------------% -c | Exit if there was an informational | -c | error within cnaup2. | -c %------------------------------------% -c - if (info .lt. 0) go to 9000 - if (info .eq. 2) info = 3 -c - if (msglvl .gt. 0) then - call ivout (logfil, 1, mxiter, ndigit, - & '_naupd: Number of update iterations taken') - call ivout (logfil, 1, np, ndigit, - & '_naupd: Number of wanted "converged" Ritz values') - call cvout (logfil, np, workl(ritz), ndigit, - & '_naupd: The final Ritz values') - call cvout (logfil, np, workl(bounds), ndigit, - & '_naupd: Associated Ritz estimates') - end if -c - call arscnd (t1) - tcaupd = t1 - t0 -c - if (msglvl .gt. 0) then -c -c %--------------------------------------------------------% -c | Version Number & Version Date are defined in version.h | -c %--------------------------------------------------------% -c - write (6,1000) - write (6,1100) mxiter, nopx, nbx, nrorth, nitref, nrstrt, - & tmvopx, tmvbx, tcaupd, tcaup2, tcaitr, titref, - & tgetv0, tceigh, tcgets, tcapps, tcconv, trvec - 1000 format (//, - & 5x, '=============================================',/ - & 5x, '= Complex implicit Arnoldi update code =',/ - & 5x, '= Version Number: ', ' 2.3' , 21x, ' =',/ - & 5x, '= Version Date: ', ' 07/31/96' , 16x, ' =',/ - & 5x, '=============================================',/ - & 5x, '= Summary of timing statistics =',/ - & 5x, '=============================================',//) - 1100 format ( - & 5x, 'Total number update iterations = ', i5,/ - & 5x, 'Total number of OP*x operations = ', i5,/ - & 5x, 'Total number of B*x operations = ', i5,/ - & 5x, 'Total number of reorthogonalization steps = ', i5,/ - & 5x, 'Total number of iterative refinement steps = ', i5,/ - & 5x, 'Total number of restart steps = ', i5,/ - & 5x, 'Total time in user OP*x operation = ', f12.6,/ - & 5x, 'Total time in user B*x operation = ', f12.6,/ - & 5x, 'Total time in Arnoldi update routine = ', f12.6,/ - & 5x, 'Total time in naup2 routine = ', f12.6,/ - & 5x, 'Total time in basic Arnoldi iteration loop = ', f12.6,/ - & 5x, 'Total time in reorthogonalization phase = ', f12.6,/ - & 5x, 'Total time in (re)start vector generation = ', f12.6,/ - & 5x, 'Total time in Hessenberg eig. subproblem = ', f12.6,/ - & 5x, 'Total time in getting the shifts = ', f12.6,/ - & 5x, 'Total time in applying the shifts = ', f12.6,/ - & 5x, 'Total time in convergence testing = ', f12.6,/ - & 5x, 'Total time in computing final Ritz vectors = ', f12.6/) - end if -c - 9000 continue -c - return -c -c %---------------% -c | End of cnaupd | -c %---------------% -c - end
--- a/libcruft/arpack/src/cneigh.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,257 +0,0 @@ -c\BeginDoc -c -c\Name: cneigh -c -c\Description: -c Compute the eigenvalues of the current upper Hessenberg matrix -c and the corresponding Ritz estimates given the current residual norm. -c -c\Usage: -c call cneigh -c ( RNORM, N, H, LDH, RITZ, BOUNDS, Q, LDQ, WORKL, RWORK, IERR ) -c -c\Arguments -c RNORM Real scalar. (INPUT) -c Residual norm corresponding to the current upper Hessenberg -c matrix H. -c -c N Integer. (INPUT) -c Size of the matrix H. -c -c H Complex N by N array. (INPUT) -c H contains the current upper Hessenberg matrix. -c -c LDH Integer. (INPUT) -c Leading dimension of H exactly as declared in the calling -c program. -c -c RITZ Complex array of length N. (OUTPUT) -c On output, RITZ(1:N) contains the eigenvalues of H. -c -c BOUNDS Complex array of length N. (OUTPUT) -c On output, BOUNDS contains the Ritz estimates associated with -c the eigenvalues held in RITZ. This is equal to RNORM -c times the last components of the eigenvectors corresponding -c to the eigenvalues in RITZ. -c -c Q Complex N by N array. (WORKSPACE) -c Workspace needed to store the eigenvectors of H. -c -c LDQ Integer. (INPUT) -c Leading dimension of Q exactly as declared in the calling -c program. -c -c WORKL Complex work array of length N**2 + 3*N. (WORKSPACE) -c Private (replicated) array on each PE or array allocated on -c the front end. This is needed to keep the full Schur form -c of H and also in the calculation of the eigenvectors of H. -c -c RWORK Real work array of length N (WORKSPACE) -c Private (replicated) array on each PE or array allocated on -c the front end. -c -c IERR Integer. (OUTPUT) -c Error exit flag from clahqr or ctrevc. -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Local variables: -c xxxxxx Complex -c -c\Routines called: -c ivout ARPACK utility routine that prints integers. -c arscnd ARPACK utility routine for timing. -c cmout ARPACK utility routine that prints matrices -c cvout ARPACK utility routine that prints vectors. -c svout ARPACK utility routine that prints vectors. -c clacpy LAPACK matrix copy routine. -c clahqr LAPACK routine to compute the Schur form of an -c upper Hessenberg matrix. -c claset LAPACK matrix initialization routine. -c ctrevc LAPACK routine to compute the eigenvectors of a matrix -c in upper triangular form -c ccopy Level 1 BLAS that copies one vector to another. -c csscal Level 1 BLAS that scales a complex vector by a real number. -c scnrm2 Level 1 BLAS that computes the norm of a vector. -c -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\SCCS Information: @(#) -c FILE: neigh.F SID: 2.2 DATE OF SID: 4/20/96 RELEASE: 2 -c -c\Remarks -c None -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine cneigh (rnorm, n, h, ldh, ritz, bounds, - & q, ldq, workl, rwork, ierr) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - integer ierr, n, ldh, ldq - Real - & rnorm -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - Complex - & bounds(n), h(ldh,n), q(ldq,n), ritz(n), - & workl(n*(n+3)) - Real - & rwork(n) -c -c %------------% -c | Parameters | -c %------------% -c - Complex - & one, zero - Real - & rone - parameter (one = (1.0E+0, 0.0E+0), zero = (0.0E+0, 0.0E+0), - & rone = 1.0E+0) -c -c %------------------------% -c | Local Scalars & Arrays | -c %------------------------% -c - logical select(1) - integer j, msglvl - Complex - & vl(1) - Real - & temp -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external clacpy, clahqr, ctrevc, ccopy, - & csscal, cmout, cvout, arscnd -c -c %--------------------% -c | External Functions | -c %--------------------% -c - Real - & scnrm2 - external scnrm2 -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c -c %-------------------------------% -c | Initialize timing statistics | -c | & message level for debugging | -c %-------------------------------% -c - call arscnd (t0) - msglvl = mceigh -c - if (msglvl .gt. 2) then - call cmout (logfil, n, n, h, ldh, ndigit, - & '_neigh: Entering upper Hessenberg matrix H ') - end if -c -c %----------------------------------------------------------% -c | 1. Compute the eigenvalues, the last components of the | -c | corresponding Schur vectors and the full Schur form T | -c | of the current upper Hessenberg matrix H. | -c | clahqr returns the full Schur form of H | -c | in WORKL(1:N**2), and the Schur vectors in q. | -c %----------------------------------------------------------% -c - call clacpy ('All', n, n, h, ldh, workl, n) - call claset ('All', n, n, zero, one, q, ldq) - call clahqr (.true., .true., n, 1, n, workl, ldh, ritz, - & 1, n, q, ldq, ierr) - if (ierr .ne. 0) go to 9000 -c - call ccopy (n, q(n-1,1), ldq, bounds, 1) - if (msglvl .gt. 1) then - call cvout (logfil, n, bounds, ndigit, - & '_neigh: last row of the Schur matrix for H') - end if -c -c %----------------------------------------------------------% -c | 2. Compute the eigenvectors of the full Schur form T and | -c | apply the Schur vectors to get the corresponding | -c | eigenvectors. | -c %----------------------------------------------------------% -c - call ctrevc ('Right', 'Back', select, n, workl, n, vl, n, q, - & ldq, n, n, workl(n*n+1), rwork, ierr) -c - if (ierr .ne. 0) go to 9000 -c -c %------------------------------------------------% -c | Scale the returning eigenvectors so that their | -c | Euclidean norms are all one. LAPACK subroutine | -c | ctrevc returns each eigenvector normalized so | -c | that the element of largest magnitude has | -c | magnitude 1; here the magnitude of a complex | -c | number (x,y) is taken to be |x| + |y|. | -c %------------------------------------------------% -c - do 10 j=1, n - temp = scnrm2( n, q(1,j), 1 ) - call csscal ( n, rone / temp, q(1,j), 1 ) - 10 continue -c - if (msglvl .gt. 1) then - call ccopy(n, q(n,1), ldq, workl, 1) - call cvout (logfil, n, workl, ndigit, - & '_neigh: Last row of the eigenvector matrix for H') - end if -c -c %----------------------------% -c | Compute the Ritz estimates | -c %----------------------------% -c - call ccopy(n, q(n,1), n, bounds, 1) - call csscal(n, rnorm, bounds, 1) -c - if (msglvl .gt. 2) then - call cvout (logfil, n, ritz, ndigit, - & '_neigh: The eigenvalues of H') - call cvout (logfil, n, bounds, ndigit, - & '_neigh: Ritz estimates for the eigenvalues of H') - end if -c - call arscnd(t1) - tceigh = tceigh + (t1 - t0) -c - 9000 continue - return -c -c %---------------% -c | End of cneigh | -c %---------------% -c - end
--- a/libcruft/arpack/src/cneupd.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,876 +0,0 @@ -c\BeginDoc -c -c\Name: cneupd -c -c\Description: -c This subroutine returns the converged approximations to eigenvalues -c of A*z = lambda*B*z and (optionally): -c -c (1) The corresponding approximate eigenvectors; -c -c (2) An orthonormal basis for the associated approximate -c invariant subspace; -c -c (3) Both. -c -c There is negligible additional cost to obtain eigenvectors. An orthonormal -c basis is always computed. There is an additional storage cost of n*nev -c if both are requested (in this case a separate array Z must be supplied). -c -c The approximate eigenvalues and eigenvectors of A*z = lambda*B*z -c are derived from approximate eigenvalues and eigenvectors of -c of the linear operator OP prescribed by the MODE selection in the -c call to CNAUPD. CNAUPD must be called before this routine is called. -c These approximate eigenvalues and vectors are commonly called Ritz -c values and Ritz vectors respectively. They are referred to as such -c in the comments that follow. The computed orthonormal basis for the -c invariant subspace corresponding to these Ritz values is referred to as a -c Schur basis. -c -c The definition of OP as well as other terms and the relation of computed -c Ritz values and vectors of OP with respect to the given problem -c A*z = lambda*B*z may be found in the header of CNAUPD. For a brief -c description, see definitions of IPARAM(7), MODE and WHICH in the -c documentation of CNAUPD. -c -c\Usage: -c call cneupd -c ( RVEC, HOWMNY, SELECT, D, Z, LDZ, SIGMA, WORKEV, BMAT, -c N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, WORKD, -c WORKL, LWORKL, RWORK, INFO ) -c -c\Arguments: -c RVEC LOGICAL (INPUT) -c Specifies whether a basis for the invariant subspace corresponding -c to the converged Ritz value approximations for the eigenproblem -c A*z = lambda*B*z is computed. -c -c RVEC = .FALSE. Compute Ritz values only. -c -c RVEC = .TRUE. Compute Ritz vectors or Schur vectors. -c See Remarks below. -c -c HOWMNY Character*1 (INPUT) -c Specifies the form of the basis for the invariant subspace -c corresponding to the converged Ritz values that is to be computed. -c -c = 'A': Compute NEV Ritz vectors; -c = 'P': Compute NEV Schur vectors; -c = 'S': compute some of the Ritz vectors, specified -c by the logical array SELECT. -c -c SELECT Logical array of dimension NCV. (INPUT) -c If HOWMNY = 'S', SELECT specifies the Ritz vectors to be -c computed. To select the Ritz vector corresponding to a -c Ritz value D(j), SELECT(j) must be set to .TRUE.. -c If HOWMNY = 'A' or 'P', SELECT need not be initialized -c but it is used as internal workspace. -c -c D Complex array of dimension NEV+1. (OUTPUT) -c On exit, D contains the Ritz approximations -c to the eigenvalues lambda for A*z = lambda*B*z. -c -c Z Complex N by NEV array (OUTPUT) -c On exit, if RVEC = .TRUE. and HOWMNY = 'A', then the columns of -c Z represents approximate eigenvectors (Ritz vectors) corresponding -c to the NCONV=IPARAM(5) Ritz values for eigensystem -c A*z = lambda*B*z. -c -c If RVEC = .FALSE. or HOWMNY = 'P', then Z is NOT REFERENCED. -c -c NOTE: If if RVEC = .TRUE. and a Schur basis is not required, -c the array Z may be set equal to first NEV+1 columns of the Arnoldi -c basis array V computed by CNAUPD. In this case the Arnoldi basis -c will be destroyed and overwritten with the eigenvector basis. -c -c LDZ Integer. (INPUT) -c The leading dimension of the array Z. If Ritz vectors are -c desired, then LDZ .ge. max( 1, N ) is required. -c In any case, LDZ .ge. 1 is required. -c -c SIGMA Complex (INPUT) -c If IPARAM(7) = 3 then SIGMA represents the shift. -c Not referenced if IPARAM(7) = 1 or 2. -c -c WORKEV Complex work array of dimension 2*NCV. (WORKSPACE) -c -c **** The remaining arguments MUST be the same as for the **** -c **** call to CNAUPD that was just completed. **** -c -c NOTE: The remaining arguments -c -c BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, -c WORKD, WORKL, LWORKL, RWORK, INFO -c -c must be passed directly to CNEUPD following the last call -c to CNAUPD. These arguments MUST NOT BE MODIFIED between -c the the last call to CNAUPD and the call to CNEUPD. -c -c Three of these parameters (V, WORKL and INFO) are also output parameters: -c -c V Complex N by NCV array. (INPUT/OUTPUT) -c -c Upon INPUT: the NCV columns of V contain the Arnoldi basis -c vectors for OP as constructed by CNAUPD . -c -c Upon OUTPUT: If RVEC = .TRUE. the first NCONV=IPARAM(5) columns -c contain approximate Schur vectors that span the -c desired invariant subspace. -c -c NOTE: If the array Z has been set equal to first NEV+1 columns -c of the array V and RVEC=.TRUE. and HOWMNY= 'A', then the -c Arnoldi basis held by V has been overwritten by the desired -c Ritz vectors. If a separate array Z has been passed then -c the first NCONV=IPARAM(5) columns of V will contain approximate -c Schur vectors that span the desired invariant subspace. -c -c WORKL Real work array of length LWORKL. (OUTPUT/WORKSPACE) -c WORKL(1:ncv*ncv+2*ncv) contains information obtained in -c cnaupd. They are not changed by cneupd. -c WORKL(ncv*ncv+2*ncv+1:3*ncv*ncv+4*ncv) holds the -c untransformed Ritz values, the untransformed error estimates of -c the Ritz values, the upper triangular matrix for H, and the -c associated matrix representation of the invariant subspace for H. -c -c Note: IPNTR(9:13) contains the pointer into WORKL for addresses -c of the above information computed by cneupd. -c ------------------------------------------------------------- -c IPNTR(9): pointer to the NCV RITZ values of the -c original system. -c IPNTR(10): Not used -c IPNTR(11): pointer to the NCV corresponding error estimates. -c IPNTR(12): pointer to the NCV by NCV upper triangular -c Schur matrix for H. -c IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors -c of the upper Hessenberg matrix H. Only referenced by -c cneupd if RVEC = .TRUE. See Remark 2 below. -c ------------------------------------------------------------- -c -c INFO Integer. (OUTPUT) -c Error flag on output. -c = 0: Normal exit. -c -c = 1: The Schur form computed by LAPACK routine csheqr -c could not be reordered by LAPACK routine ctrsen. -c Re-enter subroutine cneupd with IPARAM(5)=NCV and -c increase the size of the array D to have -c dimension at least dimension NCV and allocate at least NCV -c columns for Z. NOTE: Not necessary if Z and V share -c the same space. Please notify the authors if this error -c occurs. -c -c = -1: N must be positive. -c = -2: NEV must be positive. -c = -3: NCV-NEV >= 2 and less than or equal to N. -c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI' -c = -6: BMAT must be one of 'I' or 'G'. -c = -7: Length of private work WORKL array is not sufficient. -c = -8: Error return from LAPACK eigenvalue calculation. -c This should never happened. -c = -9: Error return from calculation of eigenvectors. -c Informational error from LAPACK routine ctrevc. -c = -10: IPARAM(7) must be 1,2,3 -c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. -c = -12: HOWMNY = 'S' not yet implemented -c = -13: HOWMNY must be one of 'A' or 'P' if RVEC = .true. -c = -14: CNAUPD did not find any eigenvalues to sufficient -c accuracy. -c = -15: CNEUPD got a different count of the number of converged -c Ritz values than CNAUPD got. This indicates the user -c probably made an error in passing data from CNAUPD to -c CNEUPD or that the data was modified before entering -c CNEUPD -c -c\BeginLib -c -c\References: -c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in -c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), -c pp 357-385. -c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly -c Restarted Arnoldi Iteration", Rice University Technical Report -c TR95-13, Department of Computational and Applied Mathematics. -c 3. B. Nour-Omid, B. N. Parlett, T. Ericsson and P. S. Jensen, -c "How to Implement the Spectral Transformation", Math Comp., -c Vol. 48, No. 178, April, 1987 pp. 664-673. -c -c\Routines called: -c ivout ARPACK utility routine that prints integers. -c cmout ARPACK utility routine that prints matrices -c cvout ARPACK utility routine that prints vectors. -c cgeqr2 LAPACK routine that computes the QR factorization of -c a matrix. -c clacpy LAPACK matrix copy routine. -c clahqr LAPACK routine that computes the Schur form of a -c upper Hessenberg matrix. -c claset LAPACK matrix initialization routine. -c ctrevc LAPACK routine to compute the eigenvectors of a matrix -c in upper triangular form. -c ctrsen LAPACK routine that re-orders the Schur form. -c cunm2r LAPACK routine that applies an orthogonal matrix in -c factored form. -c slamch LAPACK routine that determines machine constants. -c ctrmm Level 3 BLAS matrix times an upper triangular matrix. -c cgeru Level 2 BLAS rank one update to a matrix. -c ccopy Level 1 BLAS that copies one vector to another . -c cscal Level 1 BLAS that scales a vector. -c csscal Level 1 BLAS that scales a complex vector by a real number. -c scnrm2 Level 1 BLAS that computes the norm of a complex vector. -c -c\Remarks -c -c 1. Currently only HOWMNY = 'A' and 'P' are implemented. -c -c 2. Schur vectors are an orthogonal representation for the basis of -c Ritz vectors. Thus, their numerical properties are often superior. -c If RVEC = .true. then the relationship -c A * V(:,1:IPARAM(5)) = V(:,1:IPARAM(5)) * T, and -c transpose( V(:,1:IPARAM(5)) ) * V(:,1:IPARAM(5)) = I -c are approximately satisfied. -c Here T is the leading submatrix of order IPARAM(5) of the -c upper triangular matrix stored workl(ipntr(12)). -c -c\Authors -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Chao Yang Houston, Texas -c Dept. of Computational & -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\SCCS Information: @(#) -c FILE: neupd.F SID: 2.7 DATE OF SID: 09/20/00 RELEASE: 2 -c -c\EndLib -c -c----------------------------------------------------------------------- - subroutine cneupd(rvec , howmny, select, d , - & z , ldz , sigma , workev, - & bmat , n , which , nev , - & tol , resid , ncv , v , - & ldv , iparam, ipntr , workd , - & workl, lworkl, rwork , info ) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - character bmat, howmny, which*2 - logical rvec - integer info, ldz, ldv, lworkl, n, ncv, nev - Complex - & sigma - Real - & tol -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - integer iparam(11), ipntr(14) - logical select(ncv) - Real - & rwork(ncv) - Complex - & d(nev) , resid(n) , v(ldv,ncv), - & z(ldz, nev), - & workd(3*n) , workl(lworkl), workev(2*ncv) -c -c %------------% -c | Parameters | -c %------------% -c - Complex - & one, zero - parameter (one = (1.0E+0, 0.0E+0) , zero = (0.0E+0, 0.0E+0) ) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - character type*6 - integer bounds, ierr , ih , ihbds, iheig , nconv , - & invsub, iuptri, iwev , j , ldh , ldq , - & mode , msglvl, ritz , wr , k , irz , - & ibd , outncv, iq , np , numcnv, jj , - & ishift, nconv2 - Complex - & rnorm, temp, vl(1) - Real - & conds, sep, rtemp, eps23 - logical reord -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external ccopy , cgeru, cgeqr2, clacpy, cmout, - & cunm2r, ctrmm, cvout, ivout, - & clahqr -c -c %--------------------% -c | External Functions | -c %--------------------% -c - Real - & scnrm2, slamch, slapy2 - external scnrm2, slamch, slapy2 -c - Complex - & cdotc - external cdotc -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c -c %------------------------% -c | Set default parameters | -c %------------------------% -c - msglvl = mceupd - mode = iparam(7) - nconv = iparam(5) - info = 0 -c -c -c %---------------------------------% -c | Get machine dependent constant. | -c %---------------------------------% -c - eps23 = slamch('Epsilon-Machine') - eps23 = eps23**(2.0E+0 / 3.0E+0 ) -c -c %-------------------------------% -c | Quick return | -c | Check for incompatible input | -c %-------------------------------% -c - ierr = 0 -c - if (nconv .le. 0) then - ierr = -14 - else if (n .le. 0) then - ierr = -1 - else if (nev .le. 0) then - ierr = -2 - else if (ncv .le. nev+1 .or. ncv .gt. n) then - ierr = -3 - else if (which .ne. 'LM' .and. - & which .ne. 'SM' .and. - & which .ne. 'LR' .and. - & which .ne. 'SR' .and. - & which .ne. 'LI' .and. - & which .ne. 'SI') then - ierr = -5 - else if (bmat .ne. 'I' .and. bmat .ne. 'G') then - ierr = -6 - else if (lworkl .lt. 3*ncv**2 + 4*ncv) then - ierr = -7 - else if ( (howmny .ne. 'A' .and. - & howmny .ne. 'P' .and. - & howmny .ne. 'S') .and. rvec ) then - ierr = -13 - else if (howmny .eq. 'S' ) then - ierr = -12 - end if -c - if (mode .eq. 1 .or. mode .eq. 2) then - type = 'REGULR' - else if (mode .eq. 3 ) then - type = 'SHIFTI' - else - ierr = -10 - end if - if (mode .eq. 1 .and. bmat .eq. 'G') ierr = -11 -c -c %------------% -c | Error Exit | -c %------------% -c - if (ierr .ne. 0) then - info = ierr - go to 9000 - end if -c -c %--------------------------------------------------------% -c | Pointer into WORKL for address of H, RITZ, WORKEV, Q | -c | etc... and the remaining workspace. | -c | Also update pointer to be used on output. | -c | Memory is laid out as follows: | -c | workl(1:ncv*ncv) := generated Hessenberg matrix | -c | workl(ncv*ncv+1:ncv*ncv+ncv) := ritz values | -c | workl(ncv*ncv+ncv+1:ncv*ncv+2*ncv) := error bounds | -c %--------------------------------------------------------% -c -c %-----------------------------------------------------------% -c | The following is used and set by CNEUPD. | -c | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := The untransformed | -c | Ritz values. | -c | workl(ncv*ncv+3*ncv+1:ncv*ncv+4*ncv) := The untransformed | -c | error bounds of | -c | the Ritz values | -c | workl(ncv*ncv+4*ncv+1:2*ncv*ncv+4*ncv) := Holds the upper | -c | triangular matrix | -c | for H. | -c | workl(2*ncv*ncv+4*ncv+1: 3*ncv*ncv+4*ncv) := Holds the | -c | associated matrix | -c | representation of | -c | the invariant | -c | subspace for H. | -c | GRAND total of NCV * ( 3 * NCV + 4 ) locations. | -c %-----------------------------------------------------------% -c - ih = ipntr(5) - ritz = ipntr(6) - iq = ipntr(7) - bounds = ipntr(8) - ldh = ncv - ldq = ncv - iheig = bounds + ldh - ihbds = iheig + ldh - iuptri = ihbds + ldh - invsub = iuptri + ldh*ncv - ipntr(9) = iheig - ipntr(11) = ihbds - ipntr(12) = iuptri - ipntr(13) = invsub - wr = 1 - iwev = wr + ncv -c -c %-----------------------------------------% -c | irz points to the Ritz values computed | -c | by _neigh before exiting _naup2. | -c | ibd points to the Ritz estimates | -c | computed by _neigh before exiting | -c | _naup2. | -c %-----------------------------------------% -c - irz = ipntr(14) + ncv*ncv - ibd = irz + ncv -c -c %------------------------------------% -c | RNORM is B-norm of the RESID(1:N). | -c %------------------------------------% -c - rnorm = workl(ih+2) - workl(ih+2) = zero -c - if (msglvl .gt. 2) then - call cvout(logfil, ncv, workl(irz), ndigit, - & '_neupd: Ritz values passed in from _NAUPD.') - call cvout(logfil, ncv, workl(ibd), ndigit, - & '_neupd: Ritz estimates passed in from _NAUPD.') - end if -c - if (rvec) then -c - reord = .false. -c -c %---------------------------------------------------% -c | Use the temporary bounds array to store indices | -c | These will be used to mark the select array later | -c %---------------------------------------------------% -c - do 10 j = 1,ncv - workl(bounds+j-1) = j - select(j) = .false. - 10 continue -c -c %-------------------------------------% -c | Select the wanted Ritz values. | -c | Sort the Ritz values so that the | -c | wanted ones appear at the tailing | -c | NEV positions of workl(irr) and | -c | workl(iri). Move the corresponding | -c | error estimates in workl(ibd) | -c | accordingly. | -c %-------------------------------------% -c - np = ncv - nev - ishift = 0 - call cngets(ishift, which , nev , - & np , workl(irz), workl(bounds)) -c - if (msglvl .gt. 2) then - call cvout (logfil, ncv, workl(irz), ndigit, - & '_neupd: Ritz values after calling _NGETS.') - call cvout (logfil, ncv, workl(bounds), ndigit, - & '_neupd: Ritz value indices after calling _NGETS.') - end if -c -c %-----------------------------------------------------% -c | Record indices of the converged wanted Ritz values | -c | Mark the select array for possible reordering | -c %-----------------------------------------------------% -c - numcnv = 0 - do 11 j = 1,ncv - rtemp = max(eps23, - & slapy2 ( real (workl(irz+ncv-j)), - & aimag(workl(irz+ncv-j)) )) - jj = workl(bounds + ncv - j) - if (numcnv .lt. nconv .and. - & slapy2( real (workl(ibd+jj-1)), - & aimag(workl(ibd+jj-1)) ) - & .le. tol*rtemp) then - select(jj) = .true. - numcnv = numcnv + 1 - if (jj .gt. nev) reord = .true. - endif - 11 continue -c -c %-----------------------------------------------------------% -c | Check the count (numcnv) of converged Ritz values with | -c | the number (nconv) reported by dnaupd. If these two | -c | are different then there has probably been an error | -c | caused by incorrect passing of the dnaupd data. | -c %-----------------------------------------------------------% -c - if (msglvl .gt. 2) then - call ivout(logfil, 1, numcnv, ndigit, - & '_neupd: Number of specified eigenvalues') - call ivout(logfil, 1, nconv, ndigit, - & '_neupd: Number of "converged" eigenvalues') - end if -c - if (numcnv .ne. nconv) then - info = -15 - go to 9000 - end if -c -c %-------------------------------------------------------% -c | Call LAPACK routine clahqr to compute the Schur form | -c | of the upper Hessenberg matrix returned by CNAUPD. | -c | Make a copy of the upper Hessenberg matrix. | -c | Initialize the Schur vector matrix Q to the identity. | -c %-------------------------------------------------------% -c - call ccopy(ldh*ncv, workl(ih), 1, workl(iuptri), 1) - call claset('All', ncv, ncv , - & zero , one, workl(invsub), - & ldq) - call clahqr(.true., .true. , ncv , - & 1 , ncv , workl(iuptri), - & ldh , workl(iheig) , 1 , - & ncv , workl(invsub), ldq , - & ierr) - call ccopy(ncv , workl(invsub+ncv-1), ldq, - & workl(ihbds), 1) -c - if (ierr .ne. 0) then - info = -8 - go to 9000 - end if -c - if (msglvl .gt. 1) then - call cvout (logfil, ncv, workl(iheig), ndigit, - & '_neupd: Eigenvalues of H') - call cvout (logfil, ncv, workl(ihbds), ndigit, - & '_neupd: Last row of the Schur vector matrix') - if (msglvl .gt. 3) then - call cmout (logfil , ncv, ncv , - & workl(iuptri), ldh, ndigit, - & '_neupd: The upper triangular matrix ') - end if - end if -c - if (reord) then -c -c %-----------------------------------------------% -c | Reorder the computed upper triangular matrix. | -c %-----------------------------------------------% -c - call ctrsen('None' , 'V' , select , - & ncv , workl(iuptri), ldh , - & workl(invsub), ldq , workl(iheig), - & nconv2 , conds , sep , - & workev , ncv , ierr) -c - if (nconv2 .lt. nconv) then - nconv = nconv2 - end if - - if (ierr .eq. 1) then - info = 1 - go to 9000 - end if -c - if (msglvl .gt. 2) then - call cvout (logfil, ncv, workl(iheig), ndigit, - & '_neupd: Eigenvalues of H--reordered') - if (msglvl .gt. 3) then - call cmout(logfil , ncv, ncv , - & workl(iuptri), ldq, ndigit, - & '_neupd: Triangular matrix after re-ordering') - end if - end if -c - end if -c -c %---------------------------------------------% -c | Copy the last row of the Schur basis matrix | -c | to workl(ihbds). This vector will be used | -c | to compute the Ritz estimates of converged | -c | Ritz values. | -c %---------------------------------------------% -c - call ccopy(ncv , workl(invsub+ncv-1), ldq, - & workl(ihbds), 1) -c -c %--------------------------------------------% -c | Place the computed eigenvalues of H into D | -c | if a spectral transformation was not used. | -c %--------------------------------------------% -c - if (type .eq. 'REGULR') then - call ccopy(nconv, workl(iheig), 1, d, 1) - end if -c -c %----------------------------------------------------------% -c | Compute the QR factorization of the matrix representing | -c | the wanted invariant subspace located in the first NCONV | -c | columns of workl(invsub,ldq). | -c %----------------------------------------------------------% -c - call cgeqr2(ncv , nconv , workl(invsub), - & ldq , workev, workev(ncv+1), - & ierr) -c -c %--------------------------------------------------------% -c | * Postmultiply V by Q using cunm2r. | -c | * Copy the first NCONV columns of VQ into Z. | -c | * Postmultiply Z by R. | -c | The N by NCONV matrix Z is now a matrix representation | -c | of the approximate invariant subspace associated with | -c | the Ritz values in workl(iheig). The first NCONV | -c | columns of V are now approximate Schur vectors | -c | associated with the upper triangular matrix of order | -c | NCONV in workl(iuptri). | -c %--------------------------------------------------------% -c - call cunm2r('Right', 'Notranspose', n , - & ncv , nconv , workl(invsub), - & ldq , workev , v , - & ldv , workd(n+1) , ierr) - call clacpy('All', n, nconv, v, ldv, z, ldz) -c - do 20 j=1, nconv -c -c %---------------------------------------------------% -c | Perform both a column and row scaling if the | -c | diagonal element of workl(invsub,ldq) is negative | -c | I'm lazy and don't take advantage of the upper | -c | triangular form of workl(iuptri,ldq). | -c | Note that since Q is orthogonal, R is a diagonal | -c | matrix consisting of plus or minus ones. | -c %---------------------------------------------------% -c - if ( real ( workl(invsub+(j-1)*ldq+j-1) ) .lt. - & real (zero) ) then - call cscal(nconv, -one, workl(iuptri+j-1), ldq) - call cscal(nconv, -one, workl(iuptri+(j-1)*ldq), 1) - end if -c - 20 continue -c - if (howmny .eq. 'A') then -c -c %--------------------------------------------% -c | Compute the NCONV wanted eigenvectors of T | -c | located in workl(iuptri,ldq). | -c %--------------------------------------------% -c - do 30 j=1, ncv - if (j .le. nconv) then - select(j) = .true. - else - select(j) = .false. - end if - 30 continue -c - call ctrevc('Right', 'Select' , select , - & ncv , workl(iuptri), ldq , - & vl , 1 , workl(invsub), - & ldq , ncv , outncv , - & workev , rwork , ierr) -c - if (ierr .ne. 0) then - info = -9 - go to 9000 - end if -c -c %------------------------------------------------% -c | Scale the returning eigenvectors so that their | -c | Euclidean norms are all one. LAPACK subroutine | -c | ctrevc returns each eigenvector normalized so | -c | that the element of largest magnitude has | -c | magnitude 1. | -c %------------------------------------------------% -c - do 40 j=1, nconv - rtemp = scnrm2(ncv, workl(invsub+(j-1)*ldq), 1) - rtemp = real (one) / rtemp - call csscal ( ncv, rtemp, - & workl(invsub+(j-1)*ldq), 1 ) -c -c %------------------------------------------% -c | Ritz estimates can be obtained by taking | -c | the inner product of the last row of the | -c | Schur basis of H with eigenvectors of T. | -c | Note that the eigenvector matrix of T is | -c | upper triangular, thus the length of the | -c | inner product can be set to j. | -c %------------------------------------------% -c - workev(j) = cdotc(j, workl(ihbds), 1, - & workl(invsub+(j-1)*ldq), 1) - 40 continue -c - if (msglvl .gt. 2) then - call ccopy(nconv, workl(invsub+ncv-1), ldq, - & workl(ihbds), 1) - call cvout (logfil, nconv, workl(ihbds), ndigit, - & '_neupd: Last row of the eigenvector matrix for T') - if (msglvl .gt. 3) then - call cmout(logfil , ncv, ncv , - & workl(invsub), ldq, ndigit, - & '_neupd: The eigenvector matrix for T') - end if - end if -c -c %---------------------------------------% -c | Copy Ritz estimates into workl(ihbds) | -c %---------------------------------------% -c - call ccopy(nconv, workev, 1, workl(ihbds), 1) -c -c %----------------------------------------------% -c | The eigenvector matrix Q of T is triangular. | -c | Form Z*Q. | -c %----------------------------------------------% -c - call ctrmm('Right' , 'Upper' , 'No transpose', - & 'Non-unit', n , nconv , - & one , workl(invsub), ldq , - & z , ldz) - end if -c - else -c -c %--------------------------------------------------% -c | An approximate invariant subspace is not needed. | -c | Place the Ritz values computed CNAUPD into D. | -c %--------------------------------------------------% -c - call ccopy(nconv, workl(ritz), 1, d, 1) - call ccopy(nconv, workl(ritz), 1, workl(iheig), 1) - call ccopy(nconv, workl(bounds), 1, workl(ihbds), 1) -c - end if -c -c %------------------------------------------------% -c | Transform the Ritz values and possibly vectors | -c | and corresponding error bounds of OP to those | -c | of A*x = lambda*B*x. | -c %------------------------------------------------% -c - if (type .eq. 'REGULR') then -c - if (rvec) - & call cscal(ncv, rnorm, workl(ihbds), 1) -c - else -c -c %---------------------------------------% -c | A spectral transformation was used. | -c | * Determine the Ritz estimates of the | -c | Ritz values in the original system. | -c %---------------------------------------% -c - if (rvec) - & call cscal(ncv, rnorm, workl(ihbds), 1) -c - do 50 k=1, ncv - temp = workl(iheig+k-1) - workl(ihbds+k-1) = workl(ihbds+k-1) / temp / temp - 50 continue -c - end if -c -c %-----------------------------------------------------------% -c | * Transform the Ritz values back to the original system. | -c | For TYPE = 'SHIFTI' the transformation is | -c | lambda = 1/theta + sigma | -c | NOTES: | -c | *The Ritz vectors are not affected by the transformation. | -c %-----------------------------------------------------------% -c - if (type .eq. 'SHIFTI') then - do 60 k=1, nconv - d(k) = one / workl(iheig+k-1) + sigma - 60 continue - end if -c - if (type .ne. 'REGULR' .and. msglvl .gt. 1) then - call cvout (logfil, nconv, d, ndigit, - & '_neupd: Untransformed Ritz values.') - call cvout (logfil, nconv, workl(ihbds), ndigit, - & '_neupd: Ritz estimates of the untransformed Ritz values.') - else if ( msglvl .gt. 1) then - call cvout (logfil, nconv, d, ndigit, - & '_neupd: Converged Ritz values.') - call cvout (logfil, nconv, workl(ihbds), ndigit, - & '_neupd: Associated Ritz estimates.') - end if -c -c %-------------------------------------------------% -c | Eigenvector Purification step. Formally perform | -c | one of inverse subspace iteration. Only used | -c | for MODE = 3. See reference 3. | -c %-------------------------------------------------% -c - if (rvec .and. howmny .eq. 'A' .and. type .eq. 'SHIFTI') then -c -c %------------------------------------------------% -c | Purify the computed Ritz vectors by adding a | -c | little bit of the residual vector: | -c | T | -c | resid(:)*( e s ) / theta | -c | NCV | -c | where H s = s theta. | -c %------------------------------------------------% -c - do 100 j=1, nconv - if (workl(iheig+j-1) .ne. zero) then - workev(j) = workl(invsub+(j-1)*ldq+ncv-1) / - & workl(iheig+j-1) - endif - 100 continue - -c %---------------------------------------% -c | Perform a rank one update to Z and | -c | purify all the Ritz vectors together. | -c %---------------------------------------% -c - call cgeru (n, nconv, one, resid, 1, workev, 1, z, ldz) -c - end if -c - 9000 continue -c - return -c -c %---------------% -c | End of cneupd| -c %---------------% -c - end
--- a/libcruft/arpack/src/cngets.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,178 +0,0 @@ -c\BeginDoc -c -c\Name: cngets -c -c\Description: -c Given the eigenvalues of the upper Hessenberg matrix H, -c computes the NP shifts AMU that are zeros of the polynomial of -c degree NP which filters out components of the unwanted eigenvectors -c corresponding to the AMU's based on some given criteria. -c -c NOTE: call this even in the case of user specified shifts in order -c to sort the eigenvalues, and error bounds of H for later use. -c -c\Usage: -c call cngets -c ( ISHIFT, WHICH, KEV, NP, RITZ, BOUNDS ) -c -c\Arguments -c ISHIFT Integer. (INPUT) -c Method for selecting the implicit shifts at each iteration. -c ISHIFT = 0: user specified shifts -c ISHIFT = 1: exact shift with respect to the matrix H. -c -c WHICH Character*2. (INPUT) -c Shift selection criteria. -c 'LM' -> want the KEV eigenvalues of largest magnitude. -c 'SM' -> want the KEV eigenvalues of smallest magnitude. -c 'LR' -> want the KEV eigenvalues of largest REAL part. -c 'SR' -> want the KEV eigenvalues of smallest REAL part. -c 'LI' -> want the KEV eigenvalues of largest imaginary part. -c 'SI' -> want the KEV eigenvalues of smallest imaginary part. -c -c KEV Integer. (INPUT) -c The number of desired eigenvalues. -c -c NP Integer. (INPUT) -c The number of shifts to compute. -c -c RITZ Complex array of length KEV+NP. (INPUT/OUTPUT) -c On INPUT, RITZ contains the the eigenvalues of H. -c On OUTPUT, RITZ are sorted so that the unwanted -c eigenvalues are in the first NP locations and the wanted -c portion is in the last KEV locations. When exact shifts are -c selected, the unwanted part corresponds to the shifts to -c be applied. Also, if ISHIFT .eq. 1, the unwanted eigenvalues -c are further sorted so that the ones with largest Ritz values -c are first. -c -c BOUNDS Complex array of length KEV+NP. (INPUT/OUTPUT) -c Error bounds corresponding to the ordering in RITZ. -c -c -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Local variables: -c xxxxxx Complex -c -c\Routines called: -c csortc ARPACK sorting routine. -c ivout ARPACK utility routine that prints integers. -c arscnd ARPACK utility routine for timing. -c cvout ARPACK utility routine that prints vectors. -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\SCCS Information: @(#) -c FILE: ngets.F SID: 2.2 DATE OF SID: 4/20/96 RELEASE: 2 -c -c\Remarks -c 1. This routine does not keep complex conjugate pairs of -c eigenvalues together. -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine cngets ( ishift, which, kev, np, ritz, bounds) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - character*2 which - integer ishift, kev, np -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - Complex - & bounds(kev+np), ritz(kev+np) -c -c %------------% -c | Parameters | -c %------------% -c - Complex - & one, zero - parameter (one = (1.0E+0, 0.0E+0), zero = (0.0E+0, 0.0E+0)) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - integer msglvl -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external cvout, csortc, arscnd -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c -c %-------------------------------% -c | Initialize timing statistics | -c | & message level for debugging | -c %-------------------------------% -c - call arscnd (t0) - msglvl = mcgets -c - call csortc (which, .true., kev+np, ritz, bounds) -c - if ( ishift .eq. 1 ) then -c -c %-------------------------------------------------------% -c | Sort the unwanted Ritz values used as shifts so that | -c | the ones with largest Ritz estimates are first | -c | This will tend to minimize the effects of the | -c | forward instability of the iteration when the shifts | -c | are applied in subroutine cnapps. | -c | Be careful and use 'SM' since we want to sort BOUNDS! | -c %-------------------------------------------------------% -c - call csortc ( 'SM', .true., np, bounds, ritz ) -c - end if -c - call arscnd (t1) - tcgets = tcgets + (t1 - t0) -c - if (msglvl .gt. 0) then - call ivout (logfil, 1, kev, ndigit, '_ngets: KEV is') - call ivout (logfil, 1, np, ndigit, '_ngets: NP is') - call cvout (logfil, kev+np, ritz, ndigit, - & '_ngets: Eigenvalues of current H matrix ') - call cvout (logfil, kev+np, bounds, ndigit, - & '_ngets: Ritz estimates of the current KEV+NP Ritz values') - end if -c - return -c -c %---------------% -c | End of cngets | -c %---------------% -c - end
--- a/libcruft/arpack/src/csortc.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,322 +0,0 @@ -c\BeginDoc -c -c\Name: csortc -c -c\Description: -c Sorts the Complex array in X into the order -c specified by WHICH and optionally applies the permutation to the -c Real array Y. -c -c\Usage: -c call csortc -c ( WHICH, APPLY, N, X, Y ) -c -c\Arguments -c WHICH Character*2. (Input) -c 'LM' -> sort X into increasing order of magnitude. -c 'SM' -> sort X into decreasing order of magnitude. -c 'LR' -> sort X with real(X) in increasing algebraic order -c 'SR' -> sort X with real(X) in decreasing algebraic order -c 'LI' -> sort X with imag(X) in increasing algebraic order -c 'SI' -> sort X with imag(X) in decreasing algebraic order -c -c APPLY Logical. (Input) -c APPLY = .TRUE. -> apply the sorted order to array Y. -c APPLY = .FALSE. -> do not apply the sorted order to array Y. -c -c N Integer. (INPUT) -c Size of the arrays. -c -c X Complex array of length N. (INPUT/OUTPUT) -c This is the array to be sorted. -c -c Y Complex array of length N. (INPUT/OUTPUT) -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Routines called: -c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c Adapted from the sort routine in LANSO. -c -c\SCCS Information: @(#) -c FILE: sortc.F SID: 2.2 DATE OF SID: 4/20/96 RELEASE: 2 -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine csortc (which, apply, n, x, y) -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - character*2 which - logical apply - integer n -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - Complex - & x(0:n-1), y(0:n-1) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - integer i, igap, j - Complex - & temp - Real - & temp1, temp2 -c -c %--------------------% -c | External functions | -c %--------------------% -c - Real - & slapy2 -c -c %--------------------% -c | Intrinsic Functions | -c %--------------------% - Intrinsic - & real, aimag -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c - igap = n / 2 -c - if (which .eq. 'LM') then -c -c %--------------------------------------------% -c | Sort X into increasing order of magnitude. | -c %--------------------------------------------% -c - 10 continue - if (igap .eq. 0) go to 9000 -c - do 30 i = igap, n-1 - j = i-igap - 20 continue -c - if (j.lt.0) go to 30 -c - temp1 = slapy2(real(x(j)),aimag(x(j))) - temp2 = slapy2(real(x(j+igap)),aimag(x(j+igap))) -c - if (temp1.gt.temp2) then - temp = x(j) - x(j) = x(j+igap) - x(j+igap) = temp -c - if (apply) then - temp = y(j) - y(j) = y(j+igap) - y(j+igap) = temp - end if - else - go to 30 - end if - j = j-igap - go to 20 - 30 continue - igap = igap / 2 - go to 10 -c - else if (which .eq. 'SM') then -c -c %--------------------------------------------% -c | Sort X into decreasing order of magnitude. | -c %--------------------------------------------% -c - 40 continue - if (igap .eq. 0) go to 9000 -c - do 60 i = igap, n-1 - j = i-igap - 50 continue -c - if (j .lt. 0) go to 60 -c - temp1 = slapy2(real(x(j)),aimag(x(j))) - temp2 = slapy2(real(x(j+igap)),aimag(x(j+igap))) -c - if (temp1.lt.temp2) then - temp = x(j) - x(j) = x(j+igap) - x(j+igap) = temp -c - if (apply) then - temp = y(j) - y(j) = y(j+igap) - y(j+igap) = temp - end if - else - go to 60 - endif - j = j-igap - go to 50 - 60 continue - igap = igap / 2 - go to 40 -c - else if (which .eq. 'LR') then -c -c %------------------------------------------------% -c | Sort XREAL into increasing order of algebraic. | -c %------------------------------------------------% -c - 70 continue - if (igap .eq. 0) go to 9000 -c - do 90 i = igap, n-1 - j = i-igap - 80 continue -c - if (j.lt.0) go to 90 -c - if (real(x(j)).gt.real(x(j+igap))) then - temp = x(j) - x(j) = x(j+igap) - x(j+igap) = temp -c - if (apply) then - temp = y(j) - y(j) = y(j+igap) - y(j+igap) = temp - end if - else - go to 90 - endif - j = j-igap - go to 80 - 90 continue - igap = igap / 2 - go to 70 -c - else if (which .eq. 'SR') then -c -c %------------------------------------------------% -c | Sort XREAL into decreasing order of algebraic. | -c %------------------------------------------------% -c - 100 continue - if (igap .eq. 0) go to 9000 - do 120 i = igap, n-1 - j = i-igap - 110 continue -c - if (j.lt.0) go to 120 -c - if (real(x(j)).lt.real(x(j+igap))) then - temp = x(j) - x(j) = x(j+igap) - x(j+igap) = temp -c - if (apply) then - temp = y(j) - y(j) = y(j+igap) - y(j+igap) = temp - end if - else - go to 120 - endif - j = j-igap - go to 110 - 120 continue - igap = igap / 2 - go to 100 -c - else if (which .eq. 'LI') then -c -c %--------------------------------------------% -c | Sort XIMAG into increasing algebraic order | -c %--------------------------------------------% -c - 130 continue - if (igap .eq. 0) go to 9000 - do 150 i = igap, n-1 - j = i-igap - 140 continue -c - if (j.lt.0) go to 150 -c - if (aimag(x(j)).gt.aimag(x(j+igap))) then - temp = x(j) - x(j) = x(j+igap) - x(j+igap) = temp -c - if (apply) then - temp = y(j) - y(j) = y(j+igap) - y(j+igap) = temp - end if - else - go to 150 - endif - j = j-igap - go to 140 - 150 continue - igap = igap / 2 - go to 130 -c - else if (which .eq. 'SI') then -c -c %---------------------------------------------% -c | Sort XIMAG into decreasing algebraic order | -c %---------------------------------------------% -c - 160 continue - if (igap .eq. 0) go to 9000 - do 180 i = igap, n-1 - j = i-igap - 170 continue -c - if (j.lt.0) go to 180 -c - if (aimag(x(j)).lt.aimag(x(j+igap))) then - temp = x(j) - x(j) = x(j+igap) - x(j+igap) = temp -c - if (apply) then - temp = y(j) - y(j) = y(j+igap) - y(j+igap) = temp - end if - else - go to 180 - endif - j = j-igap - go to 170 - 180 continue - igap = igap / 2 - go to 160 - end if -c - 9000 continue - return -c -c %---------------% -c | End of csortc | -c %---------------% -c - end
--- a/libcruft/arpack/src/cstatn.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,51 +0,0 @@ -c -c\SCCS Information: @(#) -c FILE: statn.F SID: 2.2 DATE OF SID: 4/20/96 RELEASE: 2 -c -c %---------------------------------------------% -c | Initialize statistic and timing information | -c | for complex nonsymmetric Arnoldi code. | -c %---------------------------------------------% - - subroutine cstatn -c -c %--------------------------------% -c | See stat.doc for documentation | -c %--------------------------------% -c - include 'stat.h' - -c %-----------------------% -c | Executable Statements | -c %-----------------------% - - nopx = 0 - nbx = 0 - nrorth = 0 - nitref = 0 - nrstrt = 0 - - tcaupd = 0.0E+0 - tcaup2 = 0.0E+0 - tcaitr = 0.0E+0 - tceigh = 0.0E+0 - tcgets = 0.0E+0 - tcapps = 0.0E+0 - tcconv = 0.0E+0 - titref = 0.0E+0 - tgetv0 = 0.0E+0 - trvec = 0.0E+0 - -c %----------------------------------------------------% -c | User time including reverse communication overhead | -c %----------------------------------------------------% - tmvopx = 0.0E+0 - tmvbx = 0.0E+0 - - return -c -c %---------------% -c | End of cstatn | -c %---------------% -c - end
--- a/libcruft/arpack/src/debug.h Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,16 +0,0 @@ -c -c\SCCS Information: @(#) -c FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 -c -c %---------------------------------% -c | See debug.doc for documentation | -c %---------------------------------% - integer logfil, ndigit, mgetv0, - & msaupd, msaup2, msaitr, mseigt, msapps, msgets, mseupd, - & mnaupd, mnaup2, mnaitr, mneigh, mnapps, mngets, mneupd, - & mcaupd, mcaup2, mcaitr, mceigh, mcapps, mcgets, mceupd - common /debug/ - & logfil, ndigit, mgetv0, - & msaupd, msaup2, msaitr, mseigt, msapps, msgets, mseupd, - & mnaupd, mnaup2, mnaitr, mneigh, mnapps, mngets, mneupd, - & mcaupd, mcaup2, mcaitr, mceigh, mcapps, mcgets, mceupd
--- a/libcruft/arpack/src/dgetv0.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,419 +0,0 @@ -c----------------------------------------------------------------------- -c\BeginDoc -c -c\Name: dgetv0 -c -c\Description: -c Generate a random initial residual vector for the Arnoldi process. -c Force the residual vector to be in the range of the operator OP. -c -c\Usage: -c call dgetv0 -c ( IDO, BMAT, ITRY, INITV, N, J, V, LDV, RESID, RNORM, -c IPNTR, WORKD, IERR ) -c -c\Arguments -c IDO Integer. (INPUT/OUTPUT) -c Reverse communication flag. IDO must be zero on the first -c call to dgetv0. -c ------------------------------------------------------------- -c IDO = 0: first call to the reverse communication interface -c IDO = -1: compute Y = OP * X where -c IPNTR(1) is the pointer into WORKD for X, -c IPNTR(2) is the pointer into WORKD for Y. -c This is for the initialization phase to force the -c starting vector into the range of OP. -c IDO = 2: compute Y = B * X where -c IPNTR(1) is the pointer into WORKD for X, -c IPNTR(2) is the pointer into WORKD for Y. -c IDO = 99: done -c ------------------------------------------------------------- -c -c BMAT Character*1. (INPUT) -c BMAT specifies the type of the matrix B in the (generalized) -c eigenvalue problem A*x = lambda*B*x. -c B = 'I' -> standard eigenvalue problem A*x = lambda*x -c B = 'G' -> generalized eigenvalue problem A*x = lambda*B*x -c -c ITRY Integer. (INPUT) -c ITRY counts the number of times that dgetv0 is called. -c It should be set to 1 on the initial call to dgetv0. -c -c INITV Logical variable. (INPUT) -c .TRUE. => the initial residual vector is given in RESID. -c .FALSE. => generate a random initial residual vector. -c -c N Integer. (INPUT) -c Dimension of the problem. -c -c J Integer. (INPUT) -c Index of the residual vector to be generated, with respect to -c the Arnoldi process. J > 1 in case of a "restart". -c -c V Double precision N by J array. (INPUT) -c The first J-1 columns of V contain the current Arnoldi basis -c if this is a "restart". -c -c LDV Integer. (INPUT) -c Leading dimension of V exactly as declared in the calling -c program. -c -c RESID Double precision array of length N. (INPUT/OUTPUT) -c Initial residual vector to be generated. If RESID is -c provided, force RESID into the range of the operator OP. -c -c RNORM Double precision scalar. (OUTPUT) -c B-norm of the generated residual. -c -c IPNTR Integer array of length 3. (OUTPUT) -c -c WORKD Double precision work array of length 2*N. (REVERSE COMMUNICATION). -c On exit, WORK(1:N) = B*RESID to be used in SSAITR. -c -c IERR Integer. (OUTPUT) -c = 0: Normal exit. -c = -1: Cannot generate a nontrivial restarted residual vector -c in the range of the operator OP. -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Local variables: -c xxxxxx real -c -c\References: -c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in -c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), -c pp 357-385. -c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly -c Restarted Arnoldi Iteration", Rice University Technical Report -c TR95-13, Department of Computational and Applied Mathematics. -c -c\Routines called: -c arscnd ARPACK utility routine for timing. -c dvout ARPACK utility routine for vector output. -c dlarnv LAPACK routine for generating a random vector. -c dgemv Level 2 BLAS routine for matrix vector multiplication. -c dcopy Level 1 BLAS that copies one vector to another. -c ddot Level 1 BLAS that computes the scalar product of two vectors. -c dnrm2 Level 1 BLAS that computes the norm of a vector. -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\SCCS Information: @(#) -c FILE: getv0.F SID: 2.7 DATE OF SID: 04/07/99 RELEASE: 2 -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine dgetv0 - & ( ido, bmat, itry, initv, n, j, v, ldv, resid, rnorm, - & ipntr, workd, ierr ) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - character bmat*1 - logical initv - integer ido, ierr, itry, j, ldv, n - Double precision - & rnorm -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - integer ipntr(3) - Double precision - & resid(n), v(ldv,j), workd(2*n) -c -c %------------% -c | Parameters | -c %------------% -c - Double precision - & one, zero - parameter (one = 1.0D+0, zero = 0.0D+0) -c -c %------------------------% -c | Local Scalars & Arrays | -c %------------------------% -c - logical first, inits, orth - integer idist, iseed(4), iter, msglvl, jj - Double precision - & rnorm0 - save first, iseed, inits, iter, msglvl, orth, rnorm0 -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external dlarnv, dvout, dcopy, dgemv, arscnd -c -c %--------------------% -c | External Functions | -c %--------------------% -c - Double precision - & ddot, dnrm2 - external ddot, dnrm2 -c -c %---------------------% -c | Intrinsic Functions | -c %---------------------% -c - intrinsic abs, sqrt -c -c %-----------------% -c | Data Statements | -c %-----------------% -c - data inits /.true./ -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c -c -c %-----------------------------------% -c | Initialize the seed of the LAPACK | -c | random number generator | -c %-----------------------------------% -c - if (inits) then - iseed(1) = 1 - iseed(2) = 3 - iseed(3) = 5 - iseed(4) = 7 - inits = .false. - end if -c - if (ido .eq. 0) then -c -c %-------------------------------% -c | Initialize timing statistics | -c | & message level for debugging | -c %-------------------------------% -c - call arscnd (t0) - msglvl = mgetv0 -c - ierr = 0 - iter = 0 - first = .FALSE. - orth = .FALSE. -c -c %-----------------------------------------------------% -c | Possibly generate a random starting vector in RESID | -c | Use a LAPACK random number generator used by the | -c | matrix generation routines. | -c | idist = 1: uniform (0,1) distribution; | -c | idist = 2: uniform (-1,1) distribution; | -c | idist = 3: normal (0,1) distribution; | -c %-----------------------------------------------------% -c - if (.not.initv) then - idist = 2 - call dlarnv (idist, iseed, n, resid) - end if -c -c %----------------------------------------------------------% -c | Force the starting vector into the range of OP to handle | -c | the generalized problem when B is possibly (singular). | -c %----------------------------------------------------------% -c - call arscnd (t2) - if (bmat .eq. 'G') then - nopx = nopx + 1 - ipntr(1) = 1 - ipntr(2) = n + 1 - call dcopy (n, resid, 1, workd, 1) - ido = -1 - go to 9000 - end if - end if -c -c %-----------------------------------------% -c | Back from computing OP*(initial-vector) | -c %-----------------------------------------% -c - if (first) go to 20 -c -c %-----------------------------------------------% -c | Back from computing B*(orthogonalized-vector) | -c %-----------------------------------------------% -c - if (orth) go to 40 -c - if (bmat .eq. 'G') then - call arscnd (t3) - tmvopx = tmvopx + (t3 - t2) - end if -c -c %------------------------------------------------------% -c | Starting vector is now in the range of OP; r = OP*r; | -c | Compute B-norm of starting vector. | -c %------------------------------------------------------% -c - call arscnd (t2) - first = .TRUE. - if (bmat .eq. 'G') then - nbx = nbx + 1 - call dcopy (n, workd(n+1), 1, resid, 1) - ipntr(1) = n + 1 - ipntr(2) = 1 - ido = 2 - go to 9000 - else if (bmat .eq. 'I') then - call dcopy (n, resid, 1, workd, 1) - end if -c - 20 continue -c - if (bmat .eq. 'G') then - call arscnd (t3) - tmvbx = tmvbx + (t3 - t2) - end if -c - first = .FALSE. - if (bmat .eq. 'G') then - rnorm0 = ddot (n, resid, 1, workd, 1) - rnorm0 = sqrt(abs(rnorm0)) - else if (bmat .eq. 'I') then - rnorm0 = dnrm2(n, resid, 1) - end if - rnorm = rnorm0 -c -c %---------------------------------------------% -c | Exit if this is the very first Arnoldi step | -c %---------------------------------------------% -c - if (j .eq. 1) go to 50 -c -c %---------------------------------------------------------------- -c | Otherwise need to B-orthogonalize the starting vector against | -c | the current Arnoldi basis using Gram-Schmidt with iter. ref. | -c | This is the case where an invariant subspace is encountered | -c | in the middle of the Arnoldi factorization. | -c | | -c | s = V^{T}*B*r; r = r - V*s; | -c | | -c | Stopping criteria used for iter. ref. is discussed in | -c | Parlett's book, page 107 and in Gragg & Reichel TOMS paper. | -c %---------------------------------------------------------------% -c - orth = .TRUE. - 30 continue -c - call dgemv ('T', n, j-1, one, v, ldv, workd, 1, - & zero, workd(n+1), 1) - call dgemv ('N', n, j-1, -one, v, ldv, workd(n+1), 1, - & one, resid, 1) -c -c %----------------------------------------------------------% -c | Compute the B-norm of the orthogonalized starting vector | -c %----------------------------------------------------------% -c - call arscnd (t2) - if (bmat .eq. 'G') then - nbx = nbx + 1 - call dcopy (n, resid, 1, workd(n+1), 1) - ipntr(1) = n + 1 - ipntr(2) = 1 - ido = 2 - go to 9000 - else if (bmat .eq. 'I') then - call dcopy (n, resid, 1, workd, 1) - end if -c - 40 continue -c - if (bmat .eq. 'G') then - call arscnd (t3) - tmvbx = tmvbx + (t3 - t2) - end if -c - if (bmat .eq. 'G') then - rnorm = ddot (n, resid, 1, workd, 1) - rnorm = sqrt(abs(rnorm)) - else if (bmat .eq. 'I') then - rnorm = dnrm2(n, resid, 1) - end if -c -c %--------------------------------------% -c | Check for further orthogonalization. | -c %--------------------------------------% -c - if (msglvl .gt. 2) then - call dvout (logfil, 1, rnorm0, ndigit, - & '_getv0: re-orthonalization ; rnorm0 is') - call dvout (logfil, 1, rnorm, ndigit, - & '_getv0: re-orthonalization ; rnorm is') - end if -c - if (rnorm .gt. 0.717*rnorm0) go to 50 -c - iter = iter + 1 - if (iter .le. 5) then -c -c %-----------------------------------% -c | Perform iterative refinement step | -c %-----------------------------------% -c - rnorm0 = rnorm - go to 30 - else -c -c %------------------------------------% -c | Iterative refinement step "failed" | -c %------------------------------------% -c - do 45 jj = 1, n - resid(jj) = zero - 45 continue - rnorm = zero - ierr = -1 - end if -c - 50 continue -c - if (msglvl .gt. 0) then - call dvout (logfil, 1, rnorm, ndigit, - & '_getv0: B-norm of initial / restarted starting vector') - end if - if (msglvl .gt. 3) then - call dvout (logfil, n, resid, ndigit, - & '_getv0: initial / restarted starting vector') - end if - ido = 99 -c - call arscnd (t1) - tgetv0 = tgetv0 + (t1 - t0) -c - 9000 continue - return -c -c %---------------% -c | End of dgetv0 | -c %---------------% -c - end
--- a/libcruft/arpack/src/dlaqrb.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,521 +0,0 @@ -c----------------------------------------------------------------------- -c\BeginDoc -c -c\Name: dlaqrb -c -c\Description: -c Compute the eigenvalues and the Schur decomposition of an upper -c Hessenberg submatrix in rows and columns ILO to IHI. Only the -c last component of the Schur vectors are computed. -c -c This is mostly a modification of the LAPACK routine dlahqr. -c -c\Usage: -c call dlaqrb -c ( WANTT, N, ILO, IHI, H, LDH, WR, WI, Z, INFO ) -c -c\Arguments -c WANTT Logical variable. (INPUT) -c = .TRUE. : the full Schur form T is required; -c = .FALSE.: only eigenvalues are required. -c -c N Integer. (INPUT) -c The order of the matrix H. N >= 0. -c -c ILO Integer. (INPUT) -c IHI Integer. (INPUT) -c It is assumed that H is already upper quasi-triangular in -c rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless -c ILO = 1). SLAQRB works primarily with the Hessenberg -c submatrix in rows and columns ILO to IHI, but applies -c transformations to all of H if WANTT is .TRUE.. -c 1 <= ILO <= max(1,IHI); IHI <= N. -c -c H Double precision array, dimension (LDH,N). (INPUT/OUTPUT) -c On entry, the upper Hessenberg matrix H. -c On exit, if WANTT is .TRUE., H is upper quasi-triangular in -c rows and columns ILO:IHI, with any 2-by-2 diagonal blocks in -c standard form. If WANTT is .FALSE., the contents of H are -c unspecified on exit. -c -c LDH Integer. (INPUT) -c The leading dimension of the array H. LDH >= max(1,N). -c -c WR Double precision array, dimension (N). (OUTPUT) -c WI Double precision array, dimension (N). (OUTPUT) -c The real and imaginary parts, respectively, of the computed -c eigenvalues ILO to IHI are stored in the corresponding -c elements of WR and WI. If two eigenvalues are computed as a -c complex conjugate pair, they are stored in consecutive -c elements of WR and WI, say the i-th and (i+1)th, with -c WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the -c eigenvalues are stored in the same order as on the diagonal -c of the Schur form returned in H, with WR(i) = H(i,i), and, if -c H(i:i+1,i:i+1) is a 2-by-2 diagonal block, -c WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i). -c -c Z Double precision array, dimension (N). (OUTPUT) -c On exit Z contains the last components of the Schur vectors. -c -c INFO Integer. (OUPUT) -c = 0: successful exit -c > 0: SLAQRB failed to compute all the eigenvalues ILO to IHI -c in a total of 30*(IHI-ILO+1) iterations; if INFO = i, -c elements i+1:ihi of WR and WI contain those eigenvalues -c which have been successfully computed. -c -c\Remarks -c 1. None. -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Local variables: -c xxxxxx real -c -c\Routines called: -c dlabad LAPACK routine that computes machine constants. -c dlamch LAPACK routine that determines machine constants. -c dlanhs LAPACK routine that computes various norms of a matrix. -c dlanv2 LAPACK routine that computes the Schur factorization of -c 2 by 2 nonsymmetric matrix in standard form. -c dlarfg LAPACK Householder reflection construction routine. -c dcopy Level 1 BLAS that copies one vector to another. -c drot Level 1 BLAS that applies a rotation to a 2 by 2 matrix. - -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\Revision history: -c xx/xx/92: Version ' 2.4' -c Modified from the LAPACK routine dlahqr so that only the -c last component of the Schur vectors are computed. -c -c\SCCS Information: @(#) -c FILE: laqrb.F SID: 2.2 DATE OF SID: 8/27/96 RELEASE: 2 -c -c\Remarks -c 1. None -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine dlaqrb ( wantt, n, ilo, ihi, h, ldh, wr, wi, - & z, info ) -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - logical wantt - integer ihi, ilo, info, ldh, n -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - Double precision - & h( ldh, * ), wi( * ), wr( * ), z( * ) -c -c %------------% -c | Parameters | -c %------------% -c - Double precision - & zero, one, dat1, dat2 - parameter (zero = 0.0D+0, one = 1.0D+0, dat1 = 7.5D-1, - & dat2 = -4.375D-1) -c -c %------------------------% -c | Local Scalars & Arrays | -c %------------------------% -c - integer i, i1, i2, itn, its, j, k, l, m, nh, nr - Double precision - & cs, h00, h10, h11, h12, h21, h22, h33, h33s, - & h43h34, h44, h44s, ovfl, s, smlnum, sn, sum, - & t1, t2, t3, tst1, ulp, unfl, v1, v2, v3 - Double precision - & v( 3 ), work( 1 ) -c -c %--------------------% -c | External Functions | -c %--------------------% -c - Double precision - & dlamch, dlanhs - external dlamch, dlanhs -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external dcopy, dlabad, dlanv2, dlarfg, drot -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c - info = 0 -c -c %--------------------------% -c | Quick return if possible | -c %--------------------------% -c - if( n.eq.0 ) - & return - if( ilo.eq.ihi ) then - wr( ilo ) = h( ilo, ilo ) - wi( ilo ) = zero - return - end if -c -c %---------------------------------------------% -c | Initialize the vector of last components of | -c | the Schur vectors for accumulation. | -c %---------------------------------------------% -c - do 5 j = 1, n-1 - z(j) = zero - 5 continue - z(n) = one -c - nh = ihi - ilo + 1 -c -c %-------------------------------------------------------------% -c | Set machine-dependent constants for the stopping criterion. | -c | If norm(H) <= sqrt(OVFL), overflow should not occur. | -c %-------------------------------------------------------------% -c - unfl = dlamch( 'safe minimum' ) - ovfl = one / unfl - call dlabad( unfl, ovfl ) - ulp = dlamch( 'precision' ) - smlnum = unfl*( nh / ulp ) -c -c %---------------------------------------------------------------% -c | I1 and I2 are the indices of the first row and last column | -c | of H to which transformations must be applied. If eigenvalues | -c | only are computed, I1 and I2 are set inside the main loop. | -c | Zero out H(J+2,J) = ZERO for J=1:N if WANTT = .TRUE. | -c | else H(J+2,J) for J=ILO:IHI-ILO-1 if WANTT = .FALSE. | -c %---------------------------------------------------------------% -c - if( wantt ) then - i1 = 1 - i2 = n - do 8 i=1,i2-2 - h(i1+i+1,i) = zero - 8 continue - else - do 9 i=1, ihi-ilo-1 - h(ilo+i+1,ilo+i-1) = zero - 9 continue - end if -c -c %---------------------------------------------------% -c | ITN is the total number of QR iterations allowed. | -c %---------------------------------------------------% -c - itn = 30*nh -c -c ------------------------------------------------------------------ -c The main loop begins here. I is the loop index and decreases from -c IHI to ILO in steps of 1 or 2. Each iteration of the loop works -c with the active submatrix in rows and columns L to I. -c Eigenvalues I+1 to IHI have already converged. Either L = ILO or -c H(L,L-1) is negligible so that the matrix splits. -c ------------------------------------------------------------------ -c - i = ihi - 10 continue - l = ilo - if( i.lt.ilo ) - & go to 150 - -c %--------------------------------------------------------------% -c | Perform QR iterations on rows and columns ILO to I until a | -c | submatrix of order 1 or 2 splits off at the bottom because a | -c | subdiagonal element has become negligible. | -c %--------------------------------------------------------------% - - do 130 its = 0, itn -c -c %----------------------------------------------% -c | Look for a single small subdiagonal element. | -c %----------------------------------------------% -c - do 20 k = i, l + 1, -1 - tst1 = abs( h( k-1, k-1 ) ) + abs( h( k, k ) ) - if( tst1.eq.zero ) - & tst1 = dlanhs( '1', i-l+1, h( l, l ), ldh, work ) - if( abs( h( k, k-1 ) ).le.max( ulp*tst1, smlnum ) ) - & go to 30 - 20 continue - 30 continue - l = k - if( l.gt.ilo ) then -c -c %------------------------% -c | H(L,L-1) is negligible | -c %------------------------% -c - h( l, l-1 ) = zero - end if -c -c %-------------------------------------------------------------% -c | Exit from loop if a submatrix of order 1 or 2 has split off | -c %-------------------------------------------------------------% -c - if( l.ge.i-1 ) - & go to 140 -c -c %---------------------------------------------------------% -c | Now the active submatrix is in rows and columns L to I. | -c | If eigenvalues only are being computed, only the active | -c | submatrix need be transformed. | -c %---------------------------------------------------------% -c - if( .not.wantt ) then - i1 = l - i2 = i - end if -c - if( its.eq.10 .or. its.eq.20 ) then -c -c %-------------------% -c | Exceptional shift | -c %-------------------% -c - s = abs( h( i, i-1 ) ) + abs( h( i-1, i-2 ) ) - h44 = dat1*s - h33 = h44 - h43h34 = dat2*s*s -c - else -c -c %-----------------------------------------% -c | Prepare to use Wilkinson's double shift | -c %-----------------------------------------% -c - h44 = h( i, i ) - h33 = h( i-1, i-1 ) - h43h34 = h( i, i-1 )*h( i-1, i ) - end if -c -c %-----------------------------------------------------% -c | Look for two consecutive small subdiagonal elements | -c %-----------------------------------------------------% -c - do 40 m = i - 2, l, -1 -c -c %---------------------------------------------------------% -c | Determine the effect of starting the double-shift QR | -c | iteration at row M, and see if this would make H(M,M-1) | -c | negligible. | -c %---------------------------------------------------------% -c - h11 = h( m, m ) - h22 = h( m+1, m+1 ) - h21 = h( m+1, m ) - h12 = h( m, m+1 ) - h44s = h44 - h11 - h33s = h33 - h11 - v1 = ( h33s*h44s-h43h34 ) / h21 + h12 - v2 = h22 - h11 - h33s - h44s - v3 = h( m+2, m+1 ) - s = abs( v1 ) + abs( v2 ) + abs( v3 ) - v1 = v1 / s - v2 = v2 / s - v3 = v3 / s - v( 1 ) = v1 - v( 2 ) = v2 - v( 3 ) = v3 - if( m.eq.l ) - & go to 50 - h00 = h( m-1, m-1 ) - h10 = h( m, m-1 ) - tst1 = abs( v1 )*( abs( h00 )+abs( h11 )+abs( h22 ) ) - if( abs( h10 )*( abs( v2 )+abs( v3 ) ).le.ulp*tst1 ) - & go to 50 - 40 continue - 50 continue -c -c %----------------------% -c | Double-shift QR step | -c %----------------------% -c - do 120 k = m, i - 1 -c -c ------------------------------------------------------------ -c The first iteration of this loop determines a reflection G -c from the vector V and applies it from left and right to H, -c thus creating a nonzero bulge below the subdiagonal. -c -c Each subsequent iteration determines a reflection G to -c restore the Hessenberg form in the (K-1)th column, and thus -c chases the bulge one step toward the bottom of the active -c submatrix. NR is the order of G. -c ------------------------------------------------------------ -c - 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 -c -c %------------------------------------------------% -c | Apply G from the left to transform the rows of | -c | the matrix in columns K to I2. | -c %------------------------------------------------% -c - do 60 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 - 60 continue -c -c %----------------------------------------------------% -c | Apply G from the right to transform the columns of | -c | the matrix in rows I1 to min(K+3,I). | -c %----------------------------------------------------% -c - do 70 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 - 70 continue -c -c %----------------------------------% -c | Accumulate transformations for Z | -c %----------------------------------% -c - sum = z( k ) + v2*z( k+1 ) + v3*z( k+2 ) - z( k ) = z( k ) - sum*t1 - z( k+1 ) = z( k+1 ) - sum*t2 - z( k+2 ) = z( k+2 ) - sum*t3 - - else if( nr.eq.2 ) then -c -c %------------------------------------------------% -c | Apply G from the left to transform the rows of | -c | the matrix in columns K to I2. | -c %------------------------------------------------% -c - do 90 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 - 90 continue -c -c %----------------------------------------------------% -c | Apply G from the right to transform the columns of | -c | the matrix in rows I1 to min(K+3,I). | -c %----------------------------------------------------% -c - do 100 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 - 100 continue -c -c %----------------------------------% -c | Accumulate transformations for Z | -c %----------------------------------% -c - sum = z( k ) + v2*z( k+1 ) - z( k ) = z( k ) - sum*t1 - z( k+1 ) = z( k+1 ) - sum*t2 - end if - 120 continue - - 130 continue -c -c %-------------------------------------------------------% -c | Failure to converge in remaining number of iterations | -c %-------------------------------------------------------% -c - info = i - return - - 140 continue - - if( l.eq.i ) then -c -c %------------------------------------------------------% -c | H(I,I-1) is negligible: one eigenvalue has converged | -c %------------------------------------------------------% -c - wr( i ) = h( i, i ) - wi( i ) = zero - - else if( l.eq.i-1 ) then -c -c %--------------------------------------------------------% -c | H(I-1,I-2) is negligible; | -c | a pair of eigenvalues have converged. | -c | | -c | Transform the 2-by-2 submatrix to standard Schur form, | -c | and compute and store the eigenvalues. | -c %--------------------------------------------------------% -c - 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 -c -c %-----------------------------------------------------% -c | Apply the transformation to the rest of H and to Z, | -c | as required. | -c %-----------------------------------------------------% -c - 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 ) - sum = cs*z( i-1 ) + sn*z( i ) - z( i ) = cs*z( i ) - sn*z( i-1 ) - z( i-1 ) = sum - end if - end if -c -c %---------------------------------------------------------% -c | Decrement number of remaining iterations, and return to | -c | start of the main loop with new value of I. | -c %---------------------------------------------------------% -c - itn = itn - its - i = l - 1 - go to 10 - - 150 continue - return -c -c %---------------% -c | End of dlaqrb | -c %---------------% -c - end
--- a/libcruft/arpack/src/dnaitr.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,840 +0,0 @@ -c----------------------------------------------------------------------- -c\BeginDoc -c -c\Name: dnaitr -c -c\Description: -c Reverse communication interface for applying NP additional steps to -c a K step nonsymmetric Arnoldi factorization. -c -c Input: OP*V_{k} - V_{k}*H = r_{k}*e_{k}^T -c -c with (V_{k}^T)*B*V_{k} = I, (V_{k}^T)*B*r_{k} = 0. -c -c Output: OP*V_{k+p} - V_{k+p}*H = r_{k+p}*e_{k+p}^T -c -c with (V_{k+p}^T)*B*V_{k+p} = I, (V_{k+p}^T)*B*r_{k+p} = 0. -c -c where OP and B are as in dnaupd. The B-norm of r_{k+p} is also -c computed and returned. -c -c\Usage: -c call dnaitr -c ( IDO, BMAT, N, K, NP, NB, RESID, RNORM, V, LDV, H, LDH, -c IPNTR, WORKD, INFO ) -c -c\Arguments -c IDO Integer. (INPUT/OUTPUT) -c Reverse communication flag. -c ------------------------------------------------------------- -c IDO = 0: first call to the reverse communication interface -c IDO = -1: compute Y = OP * X where -c IPNTR(1) is the pointer into WORK for X, -c IPNTR(2) is the pointer into WORK for Y. -c This is for the restart phase to force the new -c starting vector into the range of OP. -c IDO = 1: compute Y = OP * X where -c IPNTR(1) is the pointer into WORK for X, -c IPNTR(2) is the pointer into WORK for Y, -c IPNTR(3) is the pointer into WORK for B * X. -c IDO = 2: compute Y = B * X where -c IPNTR(1) is the pointer into WORK for X, -c IPNTR(2) is the pointer into WORK for Y. -c IDO = 99: done -c ------------------------------------------------------------- -c When the routine is used in the "shift-and-invert" mode, the -c vector B * Q is already available and do not need to be -c recompute in forming OP * Q. -c -c BMAT Character*1. (INPUT) -c BMAT specifies the type of the matrix B that defines the -c semi-inner product for the operator OP. See dnaupd. -c B = 'I' -> standard eigenvalue problem A*x = lambda*x -c B = 'G' -> generalized eigenvalue problem A*x = lambda*M**x -c -c N Integer. (INPUT) -c Dimension of the eigenproblem. -c -c K Integer. (INPUT) -c Current size of V and H. -c -c NP Integer. (INPUT) -c Number of additional Arnoldi steps to take. -c -c NB Integer. (INPUT) -c Blocksize to be used in the recurrence. -c Only work for NB = 1 right now. The goal is to have a -c program that implement both the block and non-block method. -c -c RESID Double precision array of length N. (INPUT/OUTPUT) -c On INPUT: RESID contains the residual vector r_{k}. -c On OUTPUT: RESID contains the residual vector r_{k+p}. -c -c RNORM Double precision scalar. (INPUT/OUTPUT) -c B-norm of the starting residual on input. -c B-norm of the updated residual r_{k+p} on output. -c -c V Double precision N by K+NP array. (INPUT/OUTPUT) -c On INPUT: V contains the Arnoldi vectors in the first K -c columns. -c On OUTPUT: V contains the new NP Arnoldi vectors in the next -c NP columns. The first K columns are unchanged. -c -c LDV Integer. (INPUT) -c Leading dimension of V exactly as declared in the calling -c program. -c -c H Double precision (K+NP) by (K+NP) array. (INPUT/OUTPUT) -c H is used to store the generated upper Hessenberg matrix. -c -c LDH Integer. (INPUT) -c Leading dimension of H exactly as declared in the calling -c program. -c -c IPNTR Integer array of length 3. (OUTPUT) -c Pointer to mark the starting locations in the WORK for -c vectors used by the Arnoldi iteration. -c ------------------------------------------------------------- -c IPNTR(1): pointer to the current operand vector X. -c IPNTR(2): pointer to the current result vector Y. -c IPNTR(3): pointer to the vector B * X when used in the -c shift-and-invert mode. X is the current operand. -c ------------------------------------------------------------- -c -c WORKD Double precision work array of length 3*N. (REVERSE COMMUNICATION) -c Distributed array to be used in the basic Arnoldi iteration -c for reverse communication. The calling program should not -c use WORKD as temporary workspace during the iteration !!!!!! -c On input, WORKD(1:N) = B*RESID and is used to save some -c computation at the first step. -c -c INFO Integer. (OUTPUT) -c = 0: Normal exit. -c > 0: Size of the spanning invariant subspace of OP found. -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Local variables: -c xxxxxx real -c -c\References: -c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in -c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), -c pp 357-385. -c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly -c Restarted Arnoldi Iteration", Rice University Technical Report -c TR95-13, Department of Computational and Applied Mathematics. -c -c\Routines called: -c dgetv0 ARPACK routine to generate the initial vector. -c ivout ARPACK utility routine that prints integers. -c arscnd ARPACK utility routine for timing. -c dmout ARPACK utility routine that prints matrices -c dvout ARPACK utility routine that prints vectors. -c dlabad LAPACK routine that computes machine constants. -c dlamch LAPACK routine that determines machine constants. -c dlascl LAPACK routine for careful scaling of a matrix. -c dlanhs LAPACK routine that computes various norms of a matrix. -c dgemv Level 2 BLAS routine for matrix vector multiplication. -c daxpy Level 1 BLAS that computes a vector triad. -c dscal Level 1 BLAS that scales a vector. -c dcopy Level 1 BLAS that copies one vector to another . -c ddot Level 1 BLAS that computes the scalar product of two vectors. -c dnrm2 Level 1 BLAS that computes the norm of a vector. -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\Revision history: -c xx/xx/92: Version ' 2.4' -c -c\SCCS Information: @(#) -c FILE: naitr.F SID: 2.4 DATE OF SID: 8/27/96 RELEASE: 2 -c -c\Remarks -c The algorithm implemented is: -c -c restart = .false. -c Given V_{k} = [v_{1}, ..., v_{k}], r_{k}; -c r_{k} contains the initial residual vector even for k = 0; -c Also assume that rnorm = || B*r_{k} || and B*r_{k} are already -c computed by the calling program. -c -c betaj = rnorm ; p_{k+1} = B*r_{k} ; -c For j = k+1, ..., k+np Do -c 1) if ( betaj < tol ) stop or restart depending on j. -c ( At present tol is zero ) -c if ( restart ) generate a new starting vector. -c 2) v_{j} = r(j-1)/betaj; V_{j} = [V_{j-1}, v_{j}]; -c p_{j} = p_{j}/betaj -c 3) r_{j} = OP*v_{j} where OP is defined as in dnaupd -c For shift-invert mode p_{j} = B*v_{j} is already available. -c wnorm = || OP*v_{j} || -c 4) Compute the j-th step residual vector. -c w_{j} = V_{j}^T * B * OP * v_{j} -c r_{j} = OP*v_{j} - V_{j} * w_{j} -c H(:,j) = w_{j}; -c H(j,j-1) = rnorm -c rnorm = || r_(j) || -c If (rnorm > 0.717*wnorm) accept step and go back to 1) -c 5) Re-orthogonalization step: -c s = V_{j}'*B*r_{j} -c r_{j} = r_{j} - V_{j}*s; rnorm1 = || r_{j} || -c alphaj = alphaj + s_{j}; -c 6) Iterative refinement step: -c If (rnorm1 > 0.717*rnorm) then -c rnorm = rnorm1 -c accept step and go back to 1) -c Else -c rnorm = rnorm1 -c If this is the first time in step 6), go to 5) -c Else r_{j} lies in the span of V_{j} numerically. -c Set r_{j} = 0 and rnorm = 0; go to 1) -c EndIf -c End Do -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine dnaitr - & (ido, bmat, n, k, np, nb, resid, rnorm, v, ldv, h, ldh, - & ipntr, workd, info) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - character bmat*1 - integer ido, info, k, ldh, ldv, n, nb, np - Double precision - & rnorm -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - integer ipntr(3) - Double precision - & h(ldh,k+np), resid(n), v(ldv,k+np), workd(3*n) -c -c %------------% -c | Parameters | -c %------------% -c - Double precision - & one, zero - parameter (one = 1.0D+0, zero = 0.0D+0) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - logical first, orth1, orth2, rstart, step3, step4 - integer ierr, i, infol, ipj, irj, ivj, iter, itry, j, msglvl, - & jj - Double precision - & betaj, ovfl, temp1, rnorm1, smlnum, tst1, ulp, unfl, - & wnorm - save first, orth1, orth2, rstart, step3, step4, - & ierr, ipj, irj, ivj, iter, itry, j, msglvl, ovfl, - & betaj, rnorm1, smlnum, ulp, unfl, wnorm -c -c %-----------------------% -c | Local Array Arguments | -c %-----------------------% -c - Double precision - & xtemp(2) -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external daxpy, dcopy, dscal, dgemv, dgetv0, dlabad, - & dvout, dmout, ivout, arscnd -c -c %--------------------% -c | External Functions | -c %--------------------% -c - Double precision - & ddot, dnrm2, dlanhs, dlamch - external ddot, dnrm2, dlanhs, dlamch -c -c %---------------------% -c | Intrinsic Functions | -c %---------------------% -c - intrinsic abs, sqrt -c -c %-----------------% -c | Data statements | -c %-----------------% -c - data first / .true. / -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c - if (first) then -c -c %-----------------------------------------% -c | Set machine-dependent constants for the | -c | the splitting and deflation criterion. | -c | If norm(H) <= sqrt(OVFL), | -c | overflow should not occur. | -c | REFERENCE: LAPACK subroutine dlahqr | -c %-----------------------------------------% -c - unfl = dlamch( 'safe minimum' ) - ovfl = one / unfl - call dlabad( unfl, ovfl ) - ulp = dlamch( 'precision' ) - smlnum = unfl*( n / ulp ) - first = .false. - end if -c - if (ido .eq. 0) then -c -c %-------------------------------% -c | Initialize timing statistics | -c | & message level for debugging | -c %-------------------------------% -c - call arscnd (t0) - msglvl = mnaitr -c -c %------------------------------% -c | Initial call to this routine | -c %------------------------------% -c - info = 0 - step3 = .false. - step4 = .false. - rstart = .false. - orth1 = .false. - orth2 = .false. - j = k + 1 - ipj = 1 - irj = ipj + n - ivj = irj + n - end if -c -c %-------------------------------------------------% -c | When in reverse communication mode one of: | -c | STEP3, STEP4, ORTH1, ORTH2, RSTART | -c | will be .true. when .... | -c | STEP3: return from computing OP*v_{j}. | -c | STEP4: return from computing B-norm of OP*v_{j} | -c | ORTH1: return from computing B-norm of r_{j+1} | -c | ORTH2: return from computing B-norm of | -c | correction to the residual vector. | -c | RSTART: return from OP computations needed by | -c | dgetv0. | -c %-------------------------------------------------% -c - if (step3) go to 50 - if (step4) go to 60 - if (orth1) go to 70 - if (orth2) go to 90 - if (rstart) go to 30 -c -c %-----------------------------% -c | Else this is the first step | -c %-----------------------------% -c -c %--------------------------------------------------------------% -c | | -c | A R N O L D I I T E R A T I O N L O O P | -c | | -c | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) | -c %--------------------------------------------------------------% - - 1000 continue -c - if (msglvl .gt. 1) then - call ivout (logfil, 1, j, ndigit, - & '_naitr: generating Arnoldi vector number') - call dvout (logfil, 1, rnorm, ndigit, - & '_naitr: B-norm of the current residual is') - end if -c -c %---------------------------------------------------% -c | STEP 1: Check if the B norm of j-th residual | -c | vector is zero. Equivalent to determing whether | -c | an exact j-step Arnoldi factorization is present. | -c %---------------------------------------------------% -c - betaj = rnorm - if (rnorm .gt. zero) go to 40 -c -c %---------------------------------------------------% -c | Invariant subspace found, generate a new starting | -c | vector which is orthogonal to the current Arnoldi | -c | basis and continue the iteration. | -c %---------------------------------------------------% -c - if (msglvl .gt. 0) then - call ivout (logfil, 1, j, ndigit, - & '_naitr: ****** RESTART AT STEP ******') - end if -c -c %---------------------------------------------% -c | ITRY is the loop variable that controls the | -c | maximum amount of times that a restart is | -c | attempted. NRSTRT is used by stat.h | -c %---------------------------------------------% -c - betaj = zero - nrstrt = nrstrt + 1 - itry = 1 - 20 continue - rstart = .true. - ido = 0 - 30 continue -c -c %--------------------------------------% -c | If in reverse communication mode and | -c | RSTART = .true. flow returns here. | -c %--------------------------------------% -c - call dgetv0 (ido, bmat, itry, .false., n, j, v, ldv, - & resid, rnorm, ipntr, workd, ierr) - if (ido .ne. 99) go to 9000 - if (ierr .lt. 0) then - itry = itry + 1 - if (itry .le. 3) go to 20 -c -c %------------------------------------------------% -c | Give up after several restart attempts. | -c | Set INFO to the size of the invariant subspace | -c | which spans OP and exit. | -c %------------------------------------------------% -c - info = j - 1 - call arscnd (t1) - tnaitr = tnaitr + (t1 - t0) - ido = 99 - go to 9000 - end if -c - 40 continue -c -c %---------------------------------------------------------% -c | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm | -c | Note that p_{j} = B*r_{j-1}. In order to avoid overflow | -c | when reciprocating a small RNORM, test against lower | -c | machine bound. | -c %---------------------------------------------------------% -c - call dcopy (n, resid, 1, v(1,j), 1) - if (rnorm .ge. unfl) then - temp1 = one / rnorm - call dscal (n, temp1, v(1,j), 1) - call dscal (n, temp1, workd(ipj), 1) - else -c -c %-----------------------------------------% -c | To scale both v_{j} and p_{j} carefully | -c | use LAPACK routine SLASCL | -c %-----------------------------------------% -c - call dlascl ('General', i, i, rnorm, one, n, 1, - & v(1,j), n, infol) - call dlascl ('General', i, i, rnorm, one, n, 1, - & workd(ipj), n, infol) - end if -c -c %------------------------------------------------------% -c | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} | -c | Note that this is not quite yet r_{j}. See STEP 4 | -c %------------------------------------------------------% -c - step3 = .true. - nopx = nopx + 1 - call arscnd (t2) - call dcopy (n, v(1,j), 1, workd(ivj), 1) - ipntr(1) = ivj - ipntr(2) = irj - ipntr(3) = ipj - ido = 1 -c -c %-----------------------------------% -c | Exit in order to compute OP*v_{j} | -c %-----------------------------------% -c - go to 9000 - 50 continue -c -c %----------------------------------% -c | Back from reverse communication; | -c | WORKD(IRJ:IRJ+N-1) := OP*v_{j} | -c | if step3 = .true. | -c %----------------------------------% -c - call arscnd (t3) - tmvopx = tmvopx + (t3 - t2) - - step3 = .false. -c -c %------------------------------------------% -c | Put another copy of OP*v_{j} into RESID. | -c %------------------------------------------% -c - call dcopy (n, workd(irj), 1, resid, 1) -c -c %---------------------------------------% -c | STEP 4: Finish extending the Arnoldi | -c | factorization to length j. | -c %---------------------------------------% -c - call arscnd (t2) - if (bmat .eq. 'G') then - nbx = nbx + 1 - step4 = .true. - ipntr(1) = irj - ipntr(2) = ipj - ido = 2 -c -c %-------------------------------------% -c | Exit in order to compute B*OP*v_{j} | -c %-------------------------------------% -c - go to 9000 - else if (bmat .eq. 'I') then - call dcopy (n, resid, 1, workd(ipj), 1) - end if - 60 continue -c -c %----------------------------------% -c | Back from reverse communication; | -c | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j} | -c | if step4 = .true. | -c %----------------------------------% -c - if (bmat .eq. 'G') then - call arscnd (t3) - tmvbx = tmvbx + (t3 - t2) - end if -c - step4 = .false. -c -c %-------------------------------------% -c | The following is needed for STEP 5. | -c | Compute the B-norm of OP*v_{j}. | -c %-------------------------------------% -c - if (bmat .eq. 'G') then - wnorm = ddot (n, resid, 1, workd(ipj), 1) - wnorm = sqrt(abs(wnorm)) - else if (bmat .eq. 'I') then - wnorm = dnrm2(n, resid, 1) - end if -c -c %-----------------------------------------% -c | Compute the j-th residual corresponding | -c | to the j step factorization. | -c | Use Classical Gram Schmidt and compute: | -c | w_{j} <- V_{j}^T * B * OP * v_{j} | -c | r_{j} <- OP*v_{j} - V_{j} * w_{j} | -c %-----------------------------------------% -c -c -c %------------------------------------------% -c | Compute the j Fourier coefficients w_{j} | -c | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. | -c %------------------------------------------% -c - call dgemv ('T', n, j, one, v, ldv, workd(ipj), 1, - & zero, h(1,j), 1) -c -c %--------------------------------------% -c | Orthogonalize r_{j} against V_{j}. | -c | RESID contains OP*v_{j}. See STEP 3. | -c %--------------------------------------% -c - call dgemv ('N', n, j, -one, v, ldv, h(1,j), 1, - & one, resid, 1) -c - if (j .gt. 1) h(j,j-1) = betaj -c - call arscnd (t4) -c - orth1 = .true. -c - call arscnd (t2) - if (bmat .eq. 'G') then - nbx = nbx + 1 - call dcopy (n, resid, 1, workd(irj), 1) - ipntr(1) = irj - ipntr(2) = ipj - ido = 2 -c -c %----------------------------------% -c | Exit in order to compute B*r_{j} | -c %----------------------------------% -c - go to 9000 - else if (bmat .eq. 'I') then - call dcopy (n, resid, 1, workd(ipj), 1) - end if - 70 continue -c -c %---------------------------------------------------% -c | Back from reverse communication if ORTH1 = .true. | -c | WORKD(IPJ:IPJ+N-1) := B*r_{j}. | -c %---------------------------------------------------% -c - if (bmat .eq. 'G') then - call arscnd (t3) - tmvbx = tmvbx + (t3 - t2) - end if -c - orth1 = .false. -c -c %------------------------------% -c | Compute the B-norm of r_{j}. | -c %------------------------------% -c - if (bmat .eq. 'G') then - rnorm = ddot (n, resid, 1, workd(ipj), 1) - rnorm = sqrt(abs(rnorm)) - else if (bmat .eq. 'I') then - rnorm = dnrm2(n, resid, 1) - end if -c -c %-----------------------------------------------------------% -c | STEP 5: Re-orthogonalization / Iterative refinement phase | -c | Maximum NITER_ITREF tries. | -c | | -c | s = V_{j}^T * B * r_{j} | -c | r_{j} = r_{j} - V_{j}*s | -c | alphaj = alphaj + s_{j} | -c | | -c | The stopping criteria used for iterative refinement is | -c | discussed in Parlett's book SEP, page 107 and in Gragg & | -c | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. | -c | Determine if we need to correct the residual. The goal is | -c | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || | -c | The following test determines whether the sine of the | -c | angle between OP*x and the computed residual is less | -c | than or equal to 0.717. | -c %-----------------------------------------------------------% -c - if (rnorm .gt. 0.717*wnorm) go to 100 - iter = 0 - nrorth = nrorth + 1 -c -c %---------------------------------------------------% -c | Enter the Iterative refinement phase. If further | -c | refinement is necessary, loop back here. The loop | -c | variable is ITER. Perform a step of Classical | -c | Gram-Schmidt using all the Arnoldi vectors V_{j} | -c %---------------------------------------------------% -c - 80 continue -c - if (msglvl .gt. 2) then - xtemp(1) = wnorm - xtemp(2) = rnorm - call dvout (logfil, 2, xtemp, ndigit, - & '_naitr: re-orthonalization; wnorm and rnorm are') - call dvout (logfil, j, h(1,j), ndigit, - & '_naitr: j-th column of H') - end if -c -c %----------------------------------------------------% -c | Compute V_{j}^T * B * r_{j}. | -c | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). | -c %----------------------------------------------------% -c - call dgemv ('T', n, j, one, v, ldv, workd(ipj), 1, - & zero, workd(irj), 1) -c -c %---------------------------------------------% -c | Compute the correction to the residual: | -c | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). | -c | The correction to H is v(:,1:J)*H(1:J,1:J) | -c | + v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j. | -c %---------------------------------------------% -c - call dgemv ('N', n, j, -one, v, ldv, workd(irj), 1, - & one, resid, 1) - call daxpy (j, one, workd(irj), 1, h(1,j), 1) -c - orth2 = .true. - call arscnd (t2) - if (bmat .eq. 'G') then - nbx = nbx + 1 - call dcopy (n, resid, 1, workd(irj), 1) - ipntr(1) = irj - ipntr(2) = ipj - ido = 2 -c -c %-----------------------------------% -c | Exit in order to compute B*r_{j}. | -c | r_{j} is the corrected residual. | -c %-----------------------------------% -c - go to 9000 - else if (bmat .eq. 'I') then - call dcopy (n, resid, 1, workd(ipj), 1) - end if - 90 continue -c -c %---------------------------------------------------% -c | Back from reverse communication if ORTH2 = .true. | -c %---------------------------------------------------% -c - if (bmat .eq. 'G') then - call arscnd (t3) - tmvbx = tmvbx + (t3 - t2) - end if -c -c %-----------------------------------------------------% -c | Compute the B-norm of the corrected residual r_{j}. | -c %-----------------------------------------------------% -c - if (bmat .eq. 'G') then - rnorm1 = ddot (n, resid, 1, workd(ipj), 1) - rnorm1 = sqrt(abs(rnorm1)) - else if (bmat .eq. 'I') then - rnorm1 = dnrm2(n, resid, 1) - end if -c - if (msglvl .gt. 0 .and. iter .gt. 0) then - call ivout (logfil, 1, j, ndigit, - & '_naitr: Iterative refinement for Arnoldi residual') - if (msglvl .gt. 2) then - xtemp(1) = rnorm - xtemp(2) = rnorm1 - call dvout (logfil, 2, xtemp, ndigit, - & '_naitr: iterative refinement ; rnorm and rnorm1 are') - end if - end if -c -c %-----------------------------------------% -c | Determine if we need to perform another | -c | step of re-orthogonalization. | -c %-----------------------------------------% -c - if (rnorm1 .gt. 0.717*rnorm) then -c -c %---------------------------------------% -c | No need for further refinement. | -c | The cosine of the angle between the | -c | corrected residual vector and the old | -c | residual vector is greater than 0.717 | -c | In other words the corrected residual | -c | and the old residual vector share an | -c | angle of less than arcCOS(0.717) | -c %---------------------------------------% -c - rnorm = rnorm1 -c - else -c -c %-------------------------------------------% -c | Another step of iterative refinement step | -c | is required. NITREF is used by stat.h | -c %-------------------------------------------% -c - nitref = nitref + 1 - rnorm = rnorm1 - iter = iter + 1 - if (iter .le. 1) go to 80 -c -c %-------------------------------------------------% -c | Otherwise RESID is numerically in the span of V | -c %-------------------------------------------------% -c - do 95 jj = 1, n - resid(jj) = zero - 95 continue - rnorm = zero - end if -c -c %----------------------------------------------% -c | Branch here directly if iterative refinement | -c | wasn't necessary or after at most NITER_REF | -c | steps of iterative refinement. | -c %----------------------------------------------% -c - 100 continue -c - rstart = .false. - orth2 = .false. -c - call arscnd (t5) - titref = titref + (t5 - t4) -c -c %------------------------------------% -c | STEP 6: Update j = j+1; Continue | -c %------------------------------------% -c - j = j + 1 - if (j .gt. k+np) then - call arscnd (t1) - tnaitr = tnaitr + (t1 - t0) - ido = 99 - do 110 i = max(1,k), k+np-1 -c -c %--------------------------------------------% -c | Check for splitting and deflation. | -c | Use a standard test as in the QR algorithm | -c | REFERENCE: LAPACK subroutine dlahqr | -c %--------------------------------------------% -c - tst1 = abs( h( i, i ) ) + abs( h( i+1, i+1 ) ) - if( tst1.eq.zero ) - & tst1 = dlanhs( '1', k+np, h, ldh, workd(n+1) ) - if( abs( h( i+1,i ) ).le.max( ulp*tst1, smlnum ) ) - & h(i+1,i) = zero - 110 continue -c - if (msglvl .gt. 2) then - call dmout (logfil, k+np, k+np, h, ldh, ndigit, - & '_naitr: Final upper Hessenberg matrix H of order K+NP') - end if -c - go to 9000 - end if -c -c %--------------------------------------------------------% -c | Loop back to extend the factorization by another step. | -c %--------------------------------------------------------% -c - go to 1000 -c -c %---------------------------------------------------------------% -c | | -c | E N D O F M A I N I T E R A T I O N L O O P | -c | | -c %---------------------------------------------------------------% -c - 9000 continue - return -c -c %---------------% -c | End of dnaitr | -c %---------------% -c - end
--- a/libcruft/arpack/src/dnapps.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,647 +0,0 @@ -c----------------------------------------------------------------------- -c\BeginDoc -c -c\Name: dnapps -c -c\Description: -c Given the Arnoldi factorization -c -c A*V_{k} - V_{k}*H_{k} = r_{k+p}*e_{k+p}^T, -c -c apply NP implicit shifts resulting in -c -c A*(V_{k}*Q) - (V_{k}*Q)*(Q^T* H_{k}*Q) = r_{k+p}*e_{k+p}^T * Q -c -c where Q is an orthogonal matrix which is the product of rotations -c and reflections resulting from the NP bulge chage sweeps. -c The updated Arnoldi factorization becomes: -c -c A*VNEW_{k} - VNEW_{k}*HNEW_{k} = rnew_{k}*e_{k}^T. -c -c\Usage: -c call dnapps -c ( N, KEV, NP, SHIFTR, SHIFTI, V, LDV, H, LDH, RESID, Q, LDQ, -c WORKL, WORKD ) -c -c\Arguments -c N Integer. (INPUT) -c Problem size, i.e. size of matrix A. -c -c KEV Integer. (INPUT/OUTPUT) -c KEV+NP is the size of the input matrix H. -c KEV is the size of the updated matrix HNEW. KEV is only -c updated on ouput when fewer than NP shifts are applied in -c order to keep the conjugate pair together. -c -c NP Integer. (INPUT) -c Number of implicit shifts to be applied. -c -c SHIFTR, Double precision array of length NP. (INPUT) -c SHIFTI Real and imaginary part of the shifts to be applied. -c Upon, entry to dnapps, the shifts must be sorted so that the -c conjugate pairs are in consecutive locations. -c -c V Double precision N by (KEV+NP) array. (INPUT/OUTPUT) -c On INPUT, V contains the current KEV+NP Arnoldi vectors. -c On OUTPUT, V contains the updated KEV Arnoldi vectors -c in the first KEV columns of V. -c -c LDV Integer. (INPUT) -c Leading dimension of V exactly as declared in the calling -c program. -c -c H Double precision (KEV+NP) by (KEV+NP) array. (INPUT/OUTPUT) -c On INPUT, H contains the current KEV+NP by KEV+NP upper -c Hessenber matrix of the Arnoldi factorization. -c On OUTPUT, H contains the updated KEV by KEV upper Hessenberg -c matrix in the KEV leading submatrix. -c -c LDH Integer. (INPUT) -c Leading dimension of H exactly as declared in the calling -c program. -c -c RESID Double precision array of length N. (INPUT/OUTPUT) -c On INPUT, RESID contains the the residual vector r_{k+p}. -c On OUTPUT, RESID is the update residual vector rnew_{k} -c in the first KEV locations. -c -c Q Double precision KEV+NP by KEV+NP work array. (WORKSPACE) -c Work array used to accumulate the rotations and reflections -c during the bulge chase sweep. -c -c LDQ Integer. (INPUT) -c Leading dimension of Q exactly as declared in the calling -c program. -c -c WORKL Double precision work array of length (KEV+NP). (WORKSPACE) -c Private (replicated) array on each PE or array allocated on -c the front end. -c -c WORKD Double precision work array of length 2*N. (WORKSPACE) -c Distributed array used in the application of the accumulated -c orthogonal matrix Q. -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Local variables: -c xxxxxx real -c -c\References: -c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in -c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), -c pp 357-385. -c -c\Routines called: -c ivout ARPACK utility routine that prints integers. -c arscnd ARPACK utility routine for timing. -c dmout ARPACK utility routine that prints matrices. -c dvout ARPACK utility routine that prints vectors. -c dlabad LAPACK routine that computes machine constants. -c dlacpy LAPACK matrix copy routine. -c dlamch LAPACK routine that determines machine constants. -c dlanhs LAPACK routine that computes various norms of a matrix. -c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. -c dlarf LAPACK routine that applies Householder reflection to -c a matrix. -c dlarfg LAPACK Householder reflection construction routine. -c dlartg LAPACK Givens rotation construction routine. -c dlaset LAPACK matrix initialization routine. -c dgemv Level 2 BLAS routine for matrix vector multiplication. -c daxpy Level 1 BLAS that computes a vector triad. -c dcopy Level 1 BLAS that copies one vector to another . -c dscal Level 1 BLAS that scales a vector. -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\Revision history: -c xx/xx/92: Version ' 2.4' -c -c\SCCS Information: @(#) -c FILE: napps.F SID: 2.4 DATE OF SID: 3/28/97 RELEASE: 2 -c -c\Remarks -c 1. In this version, each shift is applied to all the sublocks of -c the Hessenberg matrix H and not just to the submatrix that it -c comes from. Deflation as in LAPACK routine dlahqr (QR algorithm -c for upper Hessenberg matrices ) is used. -c The subdiagonals of H are enforced to be non-negative. -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine dnapps - & ( n, kev, np, shiftr, shifti, v, ldv, h, ldh, resid, q, ldq, - & workl, workd ) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - integer kev, ldh, ldq, ldv, n, np -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - Double precision - & h(ldh,kev+np), resid(n), shifti(np), shiftr(np), - & v(ldv,kev+np), q(ldq,kev+np), workd(2*n), workl(kev+np) -c -c %------------% -c | Parameters | -c %------------% -c - Double precision - & one, zero - parameter (one = 1.0D+0, zero = 0.0D+0) -c -c %------------------------% -c | Local Scalars & Arrays | -c %------------------------% -c - integer i, iend, ir, istart, j, jj, kplusp, msglvl, nr - logical cconj, first - Double precision - & c, f, g, h11, h12, h21, h22, h32, ovfl, r, s, sigmai, - & sigmar, smlnum, ulp, unfl, u(3), t, tau, tst1 - save first, ovfl, smlnum, ulp, unfl -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external daxpy, dcopy, dscal, dlacpy, dlarfg, dlarf, - & dlaset, dlabad, arscnd, dlartg -c -c %--------------------% -c | External Functions | -c %--------------------% -c - Double precision - & dlamch, dlanhs, dlapy2 - external dlamch, dlanhs, dlapy2 -c -c %----------------------% -c | Intrinsics Functions | -c %----------------------% -c - intrinsic abs, max, min -c -c %----------------% -c | Data statments | -c %----------------% -c - data first / .true. / -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c - if (first) then -c -c %-----------------------------------------------% -c | Set machine-dependent constants for the | -c | stopping criterion. If norm(H) <= sqrt(OVFL), | -c | overflow should not occur. | -c | REFERENCE: LAPACK subroutine dlahqr | -c %-----------------------------------------------% -c - unfl = dlamch( 'safe minimum' ) - ovfl = one / unfl - call dlabad( unfl, ovfl ) - ulp = dlamch( 'precision' ) - smlnum = unfl*( n / ulp ) - first = .false. - end if -c -c %-------------------------------% -c | Initialize timing statistics | -c | & message level for debugging | -c %-------------------------------% -c - call arscnd (t0) - msglvl = mnapps - kplusp = kev + np -c -c %--------------------------------------------% -c | Initialize Q to the identity to accumulate | -c | the rotations and reflections | -c %--------------------------------------------% -c - call dlaset ('All', kplusp, kplusp, zero, one, q, ldq) -c -c %----------------------------------------------% -c | Quick return if there are no shifts to apply | -c %----------------------------------------------% -c - if (np .eq. 0) go to 9000 -c -c %----------------------------------------------% -c | Chase the bulge with the application of each | -c | implicit shift. Each shift is applied to the | -c | whole matrix including each block. | -c %----------------------------------------------% -c - cconj = .false. - do 110 jj = 1, np - sigmar = shiftr(jj) - sigmai = shifti(jj) -c - if (msglvl .gt. 2 ) then - call ivout (logfil, 1, jj, ndigit, - & '_napps: shift number.') - call dvout (logfil, 1, sigmar, ndigit, - & '_napps: The real part of the shift ') - call dvout (logfil, 1, sigmai, ndigit, - & '_napps: The imaginary part of the shift ') - end if -c -c %-------------------------------------------------% -c | The following set of conditionals is necessary | -c | in order that complex conjugate pairs of shifts | -c | are applied together or not at all. | -c %-------------------------------------------------% -c - if ( cconj ) then -c -c %-----------------------------------------% -c | cconj = .true. means the previous shift | -c | had non-zero imaginary part. | -c %-----------------------------------------% -c - cconj = .false. - go to 110 - else if ( jj .lt. np .and. abs( sigmai ) .gt. zero ) then -c -c %------------------------------------% -c | Start of a complex conjugate pair. | -c %------------------------------------% -c - cconj = .true. - else if ( jj .eq. np .and. abs( sigmai ) .gt. zero ) then -c -c %----------------------------------------------% -c | The last shift has a nonzero imaginary part. | -c | Don't apply it; thus the order of the | -c | compressed H is order KEV+1 since only np-1 | -c | were applied. | -c %----------------------------------------------% -c - kev = kev + 1 - go to 110 - end if - istart = 1 - 20 continue -c -c %--------------------------------------------------% -c | if sigmai = 0 then | -c | Apply the jj-th shift ... | -c | else | -c | Apply the jj-th and (jj+1)-th together ... | -c | (Note that jj < np at this point in the code) | -c | end | -c | to the current block of H. The next do loop | -c | determines the current block ; | -c %--------------------------------------------------% -c - do 30 i = istart, kplusp-1 -c -c %----------------------------------------% -c | Check for splitting and deflation. Use | -c | a standard test as in the QR algorithm | -c | REFERENCE: LAPACK subroutine dlahqr | -c %----------------------------------------% -c - tst1 = abs( h( i, i ) ) + abs( h( i+1, i+1 ) ) - if( tst1.eq.zero ) - & tst1 = dlanhs( '1', kplusp-jj+1, h, ldh, workl ) - if( abs( h( i+1,i ) ).le.max( ulp*tst1, smlnum ) ) then - if (msglvl .gt. 0) then - call ivout (logfil, 1, i, ndigit, - & '_napps: matrix splitting at row/column no.') - call ivout (logfil, 1, jj, ndigit, - & '_napps: matrix splitting with shift number.') - call dvout (logfil, 1, h(i+1,i), ndigit, - & '_napps: off diagonal element.') - end if - iend = i - h(i+1,i) = zero - go to 40 - end if - 30 continue - iend = kplusp - 40 continue -c - if (msglvl .gt. 2) then - call ivout (logfil, 1, istart, ndigit, - & '_napps: Start of current block ') - call ivout (logfil, 1, iend, ndigit, - & '_napps: End of current block ') - end if -c -c %------------------------------------------------% -c | No reason to apply a shift to block of order 1 | -c %------------------------------------------------% -c - if ( istart .eq. iend ) go to 100 -c -c %------------------------------------------------------% -c | If istart + 1 = iend then no reason to apply a | -c | complex conjugate pair of shifts on a 2 by 2 matrix. | -c %------------------------------------------------------% -c - if ( istart + 1 .eq. iend .and. abs( sigmai ) .gt. zero ) - & go to 100 -c - h11 = h(istart,istart) - h21 = h(istart+1,istart) - if ( abs( sigmai ) .le. zero ) then -c -c %---------------------------------------------% -c | Real-valued shift ==> apply single shift QR | -c %---------------------------------------------% -c - f = h11 - sigmar - g = h21 -c - do 80 i = istart, iend-1 -c -c %-----------------------------------------------------% -c | Contruct the plane rotation G to zero out the bulge | -c %-----------------------------------------------------% -c - call dlartg (f, g, c, s, r) - if (i .gt. istart) then -c -c %-------------------------------------------% -c | The following ensures that h(1:iend-1,1), | -c | the first iend-2 off diagonal of elements | -c | H, remain non negative. | -c %-------------------------------------------% -c - if (r .lt. zero) then - r = -r - c = -c - s = -s - end if - h(i,i-1) = r - h(i+1,i-1) = zero - end if -c -c %---------------------------------------------% -c | Apply rotation to the left of H; H <- G'*H | -c %---------------------------------------------% -c - do 50 j = i, kplusp - t = c*h(i,j) + s*h(i+1,j) - h(i+1,j) = -s*h(i,j) + c*h(i+1,j) - h(i,j) = t - 50 continue -c -c %---------------------------------------------% -c | Apply rotation to the right of H; H <- H*G | -c %---------------------------------------------% -c - do 60 j = 1, min(i+2,iend) - t = c*h(j,i) + s*h(j,i+1) - h(j,i+1) = -s*h(j,i) + c*h(j,i+1) - h(j,i) = t - 60 continue -c -c %----------------------------------------------------% -c | Accumulate the rotation in the matrix Q; Q <- Q*G | -c %----------------------------------------------------% -c - do 70 j = 1, min( i+jj, kplusp ) - t = c*q(j,i) + s*q(j,i+1) - q(j,i+1) = - s*q(j,i) + c*q(j,i+1) - q(j,i) = t - 70 continue -c -c %---------------------------% -c | Prepare for next rotation | -c %---------------------------% -c - if (i .lt. iend-1) then - f = h(i+1,i) - g = h(i+2,i) - end if - 80 continue -c -c %-----------------------------------% -c | Finished applying the real shift. | -c %-----------------------------------% -c - else -c -c %----------------------------------------------------% -c | Complex conjugate shifts ==> apply double shift QR | -c %----------------------------------------------------% -c - h12 = h(istart,istart+1) - h22 = h(istart+1,istart+1) - h32 = h(istart+2,istart+1) -c -c %---------------------------------------------------------% -c | Compute 1st column of (H - shift*I)*(H - conj(shift)*I) | -c %---------------------------------------------------------% -c - s = 2.0*sigmar - t = dlapy2 ( sigmar, sigmai ) - u(1) = ( h11 * (h11 - s) + t * t ) / h21 + h12 - u(2) = h11 + h22 - s - u(3) = h32 -c - do 90 i = istart, iend-1 -c - nr = min ( 3, iend-i+1 ) -c -c %-----------------------------------------------------% -c | Construct Householder reflector G to zero out u(1). | -c | G is of the form I - tau*( 1 u )' * ( 1 u' ). | -c %-----------------------------------------------------% -c - call dlarfg ( nr, u(1), u(2), 1, tau ) -c - if (i .gt. istart) then - h(i,i-1) = u(1) - h(i+1,i-1) = zero - if (i .lt. iend-1) h(i+2,i-1) = zero - end if - u(1) = one -c -c %--------------------------------------% -c | Apply the reflector to the left of H | -c %--------------------------------------% -c - call dlarf ('Left', nr, kplusp-i+1, u, 1, tau, - & h(i,i), ldh, workl) -c -c %---------------------------------------% -c | Apply the reflector to the right of H | -c %---------------------------------------% -c - ir = min ( i+3, iend ) - call dlarf ('Right', ir, nr, u, 1, tau, - & h(1,i), ldh, workl) -c -c %-----------------------------------------------------% -c | Accumulate the reflector in the matrix Q; Q <- Q*G | -c %-----------------------------------------------------% -c - call dlarf ('Right', kplusp, nr, u, 1, tau, - & q(1,i), ldq, workl) -c -c %----------------------------% -c | Prepare for next reflector | -c %----------------------------% -c - if (i .lt. iend-1) then - u(1) = h(i+1,i) - u(2) = h(i+2,i) - if (i .lt. iend-2) u(3) = h(i+3,i) - end if -c - 90 continue -c -c %--------------------------------------------% -c | Finished applying a complex pair of shifts | -c | to the current block | -c %--------------------------------------------% -c - end if -c - 100 continue -c -c %---------------------------------------------------------% -c | Apply the same shift to the next block if there is any. | -c %---------------------------------------------------------% -c - istart = iend + 1 - if (iend .lt. kplusp) go to 20 -c -c %---------------------------------------------% -c | Loop back to the top to get the next shift. | -c %---------------------------------------------% -c - 110 continue -c -c %--------------------------------------------------% -c | Perform a similarity transformation that makes | -c | sure that H will have non negative sub diagonals | -c %--------------------------------------------------% -c - do 120 j=1,kev - if ( h(j+1,j) .lt. zero ) then - call dscal( kplusp-j+1, -one, h(j+1,j), ldh ) - call dscal( min(j+2, kplusp), -one, h(1,j+1), 1 ) - call dscal( min(j+np+1,kplusp), -one, q(1,j+1), 1 ) - end if - 120 continue -c - do 130 i = 1, kev -c -c %--------------------------------------------% -c | Final check for splitting and deflation. | -c | Use a standard test as in the QR algorithm | -c | REFERENCE: LAPACK subroutine dlahqr | -c %--------------------------------------------% -c - tst1 = abs( h( i, i ) ) + abs( h( i+1, i+1 ) ) - if( tst1.eq.zero ) - & tst1 = dlanhs( '1', kev, h, ldh, workl ) - if( h( i+1,i ) .le. max( ulp*tst1, smlnum ) ) - & h(i+1,i) = zero - 130 continue -c -c %-------------------------------------------------% -c | Compute the (kev+1)-st column of (V*Q) and | -c | temporarily store the result in WORKD(N+1:2*N). | -c | This is needed in the residual update since we | -c | cannot GUARANTEE that the corresponding entry | -c | of H would be zero as in exact arithmetic. | -c %-------------------------------------------------% -c - if (h(kev+1,kev) .gt. zero) - & call dgemv ('N', n, kplusp, one, v, ldv, q(1,kev+1), 1, zero, - & workd(n+1), 1) -c -c %----------------------------------------------------------% -c | Compute column 1 to kev of (V*Q) in backward order | -c | taking advantage of the upper Hessenberg structure of Q. | -c %----------------------------------------------------------% -c - do 140 i = 1, kev - call dgemv ('N', n, kplusp-i+1, one, v, ldv, - & q(1,kev-i+1), 1, zero, workd, 1) - call dcopy (n, workd, 1, v(1,kplusp-i+1), 1) - 140 continue -c -c %-------------------------------------------------% -c | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). | -c %-------------------------------------------------% -c - call dlacpy ('A', n, kev, v(1,kplusp-kev+1), ldv, v, ldv) -c -c %--------------------------------------------------------------% -c | Copy the (kev+1)-st column of (V*Q) in the appropriate place | -c %--------------------------------------------------------------% -c - if (h(kev+1,kev) .gt. zero) - & call dcopy (n, workd(n+1), 1, v(1,kev+1), 1) -c -c %-------------------------------------% -c | Update the residual vector: | -c | r <- sigmak*r + betak*v(:,kev+1) | -c | where | -c | sigmak = (e_{kplusp}'*Q)*e_{kev} | -c | betak = e_{kev+1}'*H*e_{kev} | -c %-------------------------------------% -c - call dscal (n, q(kplusp,kev), resid, 1) - if (h(kev+1,kev) .gt. zero) - & call daxpy (n, h(kev+1,kev), v(1,kev+1), 1, resid, 1) -c - if (msglvl .gt. 1) then - call dvout (logfil, 1, q(kplusp,kev), ndigit, - & '_napps: sigmak = (e_{kev+p}^T*Q)*e_{kev}') - call dvout (logfil, 1, h(kev+1,kev), ndigit, - & '_napps: betak = e_{kev+1}^T*H*e_{kev}') - call ivout (logfil, 1, kev, ndigit, - & '_napps: Order of the final Hessenberg matrix ') - if (msglvl .gt. 2) then - call dmout (logfil, kev, kev, h, ldh, ndigit, - & '_napps: updated Hessenberg matrix H for next iteration') - end if -c - end if -c - 9000 continue - call arscnd (t1) - tnapps = tnapps + (t1 - t0) -c - return -c -c %---------------% -c | End of dnapps | -c %---------------% -c - end
--- a/libcruft/arpack/src/dnaup2.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,835 +0,0 @@ -c\BeginDoc -c -c\Name: dnaup2 -c -c\Description: -c Intermediate level interface called by dnaupd . -c -c\Usage: -c call dnaup2 -c ( IDO, BMAT, N, WHICH, NEV, NP, TOL, RESID, MODE, IUPD, -c ISHIFT, MXITER, V, LDV, H, LDH, RITZR, RITZI, BOUNDS, -c Q, LDQ, WORKL, IPNTR, WORKD, INFO ) -c -c\Arguments -c -c IDO, BMAT, N, WHICH, NEV, TOL, RESID: same as defined in dnaupd . -c MODE, ISHIFT, MXITER: see the definition of IPARAM in dnaupd . -c -c NP Integer. (INPUT/OUTPUT) -c Contains the number of implicit shifts to apply during -c each Arnoldi iteration. -c If ISHIFT=1, NP is adjusted dynamically at each iteration -c to accelerate convergence and prevent stagnation. -c This is also roughly equal to the number of matrix-vector -c products (involving the operator OP) per Arnoldi iteration. -c The logic for adjusting is contained within the current -c subroutine. -c If ISHIFT=0, NP is the number of shifts the user needs -c to provide via reverse comunication. 0 < NP < NCV-NEV. -c NP may be less than NCV-NEV for two reasons. The first, is -c to keep complex conjugate pairs of "wanted" Ritz values -c together. The second, is that a leading block of the current -c upper Hessenberg matrix has split off and contains "unwanted" -c Ritz values. -c Upon termination of the IRA iteration, NP contains the number -c of "converged" wanted Ritz values. -c -c IUPD Integer. (INPUT) -c IUPD .EQ. 0: use explicit restart instead implicit update. -c IUPD .NE. 0: use implicit update. -c -c V Double precision N by (NEV+NP) array. (INPUT/OUTPUT) -c The Arnoldi basis vectors are returned in the first NEV -c columns of V. -c -c LDV Integer. (INPUT) -c Leading dimension of V exactly as declared in the calling -c program. -c -c H Double precision (NEV+NP) by (NEV+NP) array. (OUTPUT) -c H is used to store the generated upper Hessenberg matrix -c -c LDH Integer. (INPUT) -c Leading dimension of H exactly as declared in the calling -c program. -c -c RITZR, Double precision arrays of length NEV+NP. (OUTPUT) -c RITZI RITZR(1:NEV) (resp. RITZI(1:NEV)) contains the real (resp. -c imaginary) part of the computed Ritz values of OP. -c -c BOUNDS Double precision array of length NEV+NP. (OUTPUT) -c BOUNDS(1:NEV) contain the error bounds corresponding to -c the computed Ritz values. -c -c Q Double precision (NEV+NP) by (NEV+NP) array. (WORKSPACE) -c Private (replicated) work array used to accumulate the -c rotation in the shift application step. -c -c LDQ Integer. (INPUT) -c Leading dimension of Q exactly as declared in the calling -c program. -c -c WORKL Double precision work array of length at least -c (NEV+NP)**2 + 3*(NEV+NP). (INPUT/WORKSPACE) -c Private (replicated) array on each PE or array allocated on -c the front end. It is used in shifts calculation, shifts -c application and convergence checking. -c -c On exit, the last 3*(NEV+NP) locations of WORKL contain -c the Ritz values (real,imaginary) and associated Ritz -c estimates of the current Hessenberg matrix. They are -c listed in the same order as returned from dneigh . -c -c If ISHIFT .EQ. O and IDO .EQ. 3, the first 2*NP locations -c of WORKL are used in reverse communication to hold the user -c supplied shifts. -c -c IPNTR Integer array of length 3. (OUTPUT) -c Pointer to mark the starting locations in the WORKD for -c vectors used by the Arnoldi iteration. -c ------------------------------------------------------------- -c IPNTR(1): pointer to the current operand vector X. -c IPNTR(2): pointer to the current result vector Y. -c IPNTR(3): pointer to the vector B * X when used in the -c shift-and-invert mode. X is the current operand. -c ------------------------------------------------------------- -c -c WORKD Double precision work array of length 3*N. (WORKSPACE) -c Distributed array to be used in the basic Arnoldi iteration -c for reverse communication. The user should not use WORKD -c as temporary workspace during the iteration !!!!!!!!!! -c See Data Distribution Note in DNAUPD. -c -c INFO Integer. (INPUT/OUTPUT) -c If INFO .EQ. 0, a randomly initial residual vector is used. -c If INFO .NE. 0, RESID contains the initial residual vector, -c possibly from a previous run. -c Error flag on output. -c = 0: Normal return. -c = 1: Maximum number of iterations taken. -c All possible eigenvalues of OP has been found. -c NP returns the number of converged Ritz values. -c = 2: No shifts could be applied. -c = -8: Error return from LAPACK eigenvalue calculation; -c This should never happen. -c = -9: Starting vector is zero. -c = -9999: Could not build an Arnoldi factorization. -c Size that was built in returned in NP. -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Local variables: -c xxxxxx real -c -c\References: -c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in -c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), -c pp 357-385. -c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly -c Restarted Arnoldi Iteration", Rice University Technical Report -c TR95-13, Department of Computational and Applied Mathematics. -c -c\Routines called: -c dgetv0 ARPACK initial vector generation routine. -c dnaitr ARPACK Arnoldi factorization routine. -c dnapps ARPACK application of implicit shifts routine. -c dnconv ARPACK convergence of Ritz values routine. -c dneigh ARPACK compute Ritz values and error bounds routine. -c dngets ARPACK reorder Ritz values and error bounds routine. -c dsortc ARPACK sorting routine. -c ivout ARPACK utility routine that prints integers. -c arscnd ARPACK utility routine for timing. -c dmout ARPACK utility routine that prints matrices -c dvout ARPACK utility routine that prints vectors. -c dlamch LAPACK routine that determines machine constants. -c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. -c dcopy Level 1 BLAS that copies one vector to another . -c ddot Level 1 BLAS that computes the scalar product of two vectors. -c dnrm2 Level 1 BLAS that computes the norm of a vector. -c dswap Level 1 BLAS that swaps two vectors. -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\SCCS Information: @(#) -c FILE: naup2.F SID: 2.8 DATE OF SID: 10/17/00 RELEASE: 2 -c -c\Remarks -c 1. None -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine dnaup2 - & ( ido, bmat, n, which, nev, np, tol, resid, mode, iupd, - & ishift, mxiter, v, ldv, h, ldh, ritzr, ritzi, bounds, - & q, ldq, workl, ipntr, workd, info ) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - character bmat*1, which*2 - integer ido, info, ishift, iupd, mode, ldh, ldq, ldv, mxiter, - & n, nev, np - Double precision - & tol -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - integer ipntr(13) - Double precision - & bounds(nev+np), h(ldh,nev+np), q(ldq,nev+np), resid(n), - & ritzi(nev+np), ritzr(nev+np), v(ldv,nev+np), - & workd(3*n), workl( (nev+np)*(nev+np+3) ) -c -c %------------% -c | Parameters | -c %------------% -c - Double precision - & one, zero - parameter (one = 1.0D+0 , zero = 0.0D+0 ) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - character wprime*2 - logical cnorm , getv0, initv, update, ushift - integer ierr , iter , j , kplusp, msglvl, nconv, - & nevbef, nev0 , np0 , nptemp, numcnv - Double precision - & rnorm , temp , eps23 - save cnorm , getv0, initv, update, ushift, - & rnorm , iter , eps23, kplusp, msglvl, nconv , - & nevbef, nev0 , np0 , numcnv -c -c %-----------------------% -c | Local array arguments | -c %-----------------------% -c - integer kp(4) -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external dcopy , dgetv0 , dnaitr , dnconv , dneigh , - & dngets , dnapps , dvout , ivout , arscnd -c -c %--------------------% -c | External Functions | -c %--------------------% -c - Double precision - & ddot , dnrm2 , dlapy2 , dlamch - external ddot , dnrm2 , dlapy2 , dlamch -c -c %---------------------% -c | Intrinsic Functions | -c %---------------------% -c - intrinsic min, max, abs, sqrt -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c - if (ido .eq. 0) then -c - call arscnd (t0) -c - msglvl = mnaup2 -c -c %-------------------------------------% -c | Get the machine dependent constant. | -c %-------------------------------------% -c - eps23 = dlamch ('Epsilon-Machine') - eps23 = eps23**(2.0D+0 / 3.0D+0 ) -c - nev0 = nev - np0 = np -c -c %-------------------------------------% -c | kplusp is the bound on the largest | -c | Lanczos factorization built. | -c | nconv is the current number of | -c | "converged" eigenvlues. | -c | iter is the counter on the current | -c | iteration step. | -c %-------------------------------------% -c - kplusp = nev + np - nconv = 0 - iter = 0 -c -c %---------------------------------------% -c | Set flags for computing the first NEV | -c | steps of the Arnoldi factorization. | -c %---------------------------------------% -c - getv0 = .true. - update = .false. - ushift = .false. - cnorm = .false. -c - if (info .ne. 0) then -c -c %--------------------------------------------% -c | User provides the initial residual vector. | -c %--------------------------------------------% -c - initv = .true. - info = 0 - else - initv = .false. - end if - end if -c -c %---------------------------------------------% -c | Get a possibly random starting vector and | -c | force it into the range of the operator OP. | -c %---------------------------------------------% -c - 10 continue -c - if (getv0) then - call dgetv0 (ido, bmat, 1, initv, n, 1, v, ldv, resid, rnorm, - & ipntr, workd, info) -c - if (ido .ne. 99) go to 9000 -c - if (rnorm .eq. zero) then -c -c %-----------------------------------------% -c | The initial vector is zero. Error exit. | -c %-----------------------------------------% -c - info = -9 - go to 1100 - end if - getv0 = .false. - ido = 0 - end if -c -c %-----------------------------------% -c | Back from reverse communication : | -c | continue with update step | -c %-----------------------------------% -c - if (update) go to 20 -c -c %-------------------------------------------% -c | Back from computing user specified shifts | -c %-------------------------------------------% -c - if (ushift) go to 50 -c -c %-------------------------------------% -c | Back from computing residual norm | -c | at the end of the current iteration | -c %-------------------------------------% -c - if (cnorm) go to 100 -c -c %----------------------------------------------------------% -c | Compute the first NEV steps of the Arnoldi factorization | -c %----------------------------------------------------------% -c - call dnaitr (ido, bmat, n, 0, nev, mode, resid, rnorm, v, ldv, - & h, ldh, ipntr, workd, info) -c -c %---------------------------------------------------% -c | ido .ne. 99 implies use of reverse communication | -c | to compute operations involving OP and possibly B | -c %---------------------------------------------------% -c - if (ido .ne. 99) go to 9000 -c - if (info .gt. 0) then - np = info - mxiter = iter - info = -9999 - go to 1200 - end if -c -c %--------------------------------------------------------------% -c | | -c | M A I N ARNOLDI I T E R A T I O N L O O P | -c | Each iteration implicitly restarts the Arnoldi | -c | factorization in place. | -c | | -c %--------------------------------------------------------------% -c - 1000 continue -c - iter = iter + 1 -c - if (msglvl .gt. 0) then - call ivout (logfil, 1, iter, ndigit, - & '_naup2: **** Start of major iteration number ****') - end if -c -c %-----------------------------------------------------------% -c | Compute NP additional steps of the Arnoldi factorization. | -c | Adjust NP since NEV might have been updated by last call | -c | to the shift application routine dnapps . | -c %-----------------------------------------------------------% -c - np = kplusp - nev -c - if (msglvl .gt. 1) then - call ivout (logfil, 1, nev, ndigit, - & '_naup2: The length of the current Arnoldi factorization') - call ivout (logfil, 1, np, ndigit, - & '_naup2: Extend the Arnoldi factorization by') - end if -c -c %-----------------------------------------------------------% -c | Compute NP additional steps of the Arnoldi factorization. | -c %-----------------------------------------------------------% -c - ido = 0 - 20 continue - update = .true. -c - call dnaitr (ido , bmat, n , nev, np , mode , resid, - & rnorm, v , ldv, h , ldh, ipntr, workd, - & info) -c -c %---------------------------------------------------% -c | ido .ne. 99 implies use of reverse communication | -c | to compute operations involving OP and possibly B | -c %---------------------------------------------------% -c - if (ido .ne. 99) go to 9000 -c - if (info .gt. 0) then - np = info - mxiter = iter - info = -9999 - go to 1200 - end if - update = .false. -c - if (msglvl .gt. 1) then - call dvout (logfil, 1, rnorm, ndigit, - & '_naup2: Corresponding B-norm of the residual') - end if -c -c %--------------------------------------------------------% -c | Compute the eigenvalues and corresponding error bounds | -c | of the current upper Hessenberg matrix. | -c %--------------------------------------------------------% -c - call dneigh (rnorm, kplusp, h, ldh, ritzr, ritzi, bounds, - & q, ldq, workl, ierr) -c - if (ierr .ne. 0) then - info = -8 - go to 1200 - end if -c -c %----------------------------------------------------% -c | Make a copy of eigenvalues and corresponding error | -c | bounds obtained from dneigh . | -c %----------------------------------------------------% -c - call dcopy (kplusp, ritzr, 1, workl(kplusp**2+1), 1) - call dcopy (kplusp, ritzi, 1, workl(kplusp**2+kplusp+1), 1) - call dcopy (kplusp, bounds, 1, workl(kplusp**2+2*kplusp+1), 1) -c -c %---------------------------------------------------% -c | Select the wanted Ritz values and their bounds | -c | to be used in the convergence test. | -c | The wanted part of the spectrum and corresponding | -c | error bounds are in the last NEV loc. of RITZR, | -c | RITZI and BOUNDS respectively. The variables NEV | -c | and NP may be updated if the NEV-th wanted Ritz | -c | value has a non zero imaginary part. In this case | -c | NEV is increased by one and NP decreased by one. | -c | NOTE: The last two arguments of dngets are no | -c | longer used as of version 2.1. | -c %---------------------------------------------------% -c - nev = nev0 - np = np0 - numcnv = nev - call dngets (ishift, which, nev, np, ritzr, ritzi, - & bounds, workl, workl(np+1)) - if (nev .eq. nev0+1) numcnv = nev0+1 -c -c %-------------------% -c | Convergence test. | -c %-------------------% -c - call dcopy (nev, bounds(np+1), 1, workl(2*np+1), 1) - call dnconv (nev, ritzr(np+1), ritzi(np+1), workl(2*np+1), - & tol, nconv) -c - if (msglvl .gt. 2) then - kp(1) = nev - kp(2) = np - kp(3) = numcnv - kp(4) = nconv - call ivout (logfil, 4, kp, ndigit, - & '_naup2: NEV, NP, NUMCNV, NCONV are') - call dvout (logfil, kplusp, ritzr, ndigit, - & '_naup2: Real part of the eigenvalues of H') - call dvout (logfil, kplusp, ritzi, ndigit, - & '_naup2: Imaginary part of the eigenvalues of H') - call dvout (logfil, kplusp, bounds, ndigit, - & '_naup2: Ritz estimates of the current NCV Ritz values') - end if -c -c %---------------------------------------------------------% -c | Count the number of unwanted Ritz values that have zero | -c | Ritz estimates. If any Ritz estimates are equal to zero | -c | then a leading block of H of order equal to at least | -c | the number of Ritz values with zero Ritz estimates has | -c | split off. None of these Ritz values may be removed by | -c | shifting. Decrease NP the number of shifts to apply. If | -c | no shifts may be applied, then prepare to exit | -c %---------------------------------------------------------% -c - nptemp = np - do 30 j=1, nptemp - if (bounds(j) .eq. zero) then - np = np - 1 - nev = nev + 1 - end if - 30 continue -c - if ( (nconv .ge. numcnv) .or. - & (iter .gt. mxiter) .or. - & (np .eq. 0) ) then -c - if (msglvl .gt. 4) then - call dvout (logfil, kplusp, workl(kplusp**2+1), ndigit, - & '_naup2: Real part of the eig computed by _neigh:') - call dvout (logfil, kplusp, workl(kplusp**2+kplusp+1), - & ndigit, - & '_naup2: Imag part of the eig computed by _neigh:') - call dvout (logfil, kplusp, workl(kplusp**2+kplusp*2+1), - & ndigit, - & '_naup2: Ritz eistmates computed by _neigh:') - end if -c -c %------------------------------------------------% -c | Prepare to exit. Put the converged Ritz values | -c | and corresponding bounds in RITZ(1:NCONV) and | -c | BOUNDS(1:NCONV) respectively. Then sort. Be | -c | careful when NCONV > NP | -c %------------------------------------------------% -c -c %------------------------------------------% -c | Use h( 3,1 ) as storage to communicate | -c | rnorm to _neupd if needed | -c %------------------------------------------% - - h(3,1) = rnorm -c -c %----------------------------------------------% -c | To be consistent with dngets , we first do a | -c | pre-processing sort in order to keep complex | -c | conjugate pairs together. This is similar | -c | to the pre-processing sort used in dngets | -c | except that the sort is done in the opposite | -c | order. | -c %----------------------------------------------% -c - if (which .eq. 'LM') wprime = 'SR' - if (which .eq. 'SM') wprime = 'LR' - if (which .eq. 'LR') wprime = 'SM' - if (which .eq. 'SR') wprime = 'LM' - if (which .eq. 'LI') wprime = 'SM' - if (which .eq. 'SI') wprime = 'LM' -c - call dsortc (wprime, .true., kplusp, ritzr, ritzi, bounds) -c -c %----------------------------------------------% -c | Now sort Ritz values so that converged Ritz | -c | values appear within the first NEV locations | -c | of ritzr, ritzi and bounds, and the most | -c | desired one appears at the front. | -c %----------------------------------------------% -c - if (which .eq. 'LM') wprime = 'SM' - if (which .eq. 'SM') wprime = 'LM' - if (which .eq. 'LR') wprime = 'SR' - if (which .eq. 'SR') wprime = 'LR' - if (which .eq. 'LI') wprime = 'SI' - if (which .eq. 'SI') wprime = 'LI' -c - call dsortc (wprime, .true., kplusp, ritzr, ritzi, bounds) -c -c %--------------------------------------------------% -c | Scale the Ritz estimate of each Ritz value | -c | by 1 / max(eps23,magnitude of the Ritz value). | -c %--------------------------------------------------% -c - do 35 j = 1, numcnv - temp = max(eps23,dlapy2 (ritzr(j), - & ritzi(j))) - bounds(j) = bounds(j)/temp - 35 continue -c -c %----------------------------------------------------% -c | Sort the Ritz values according to the scaled Ritz | -c | esitmates. This will push all the converged ones | -c | towards the front of ritzr, ritzi, bounds | -c | (in the case when NCONV < NEV.) | -c %----------------------------------------------------% -c - wprime = 'LR' - call dsortc (wprime, .true., numcnv, bounds, ritzr, ritzi) -c -c %----------------------------------------------% -c | Scale the Ritz estimate back to its original | -c | value. | -c %----------------------------------------------% -c - do 40 j = 1, numcnv - temp = max(eps23, dlapy2 (ritzr(j), - & ritzi(j))) - bounds(j) = bounds(j)*temp - 40 continue -c -c %------------------------------------------------% -c | Sort the converged Ritz values again so that | -c | the "threshold" value appears at the front of | -c | ritzr, ritzi and bound. | -c %------------------------------------------------% -c - call dsortc (which, .true., nconv, ritzr, ritzi, bounds) -c - if (msglvl .gt. 1) then - call dvout (logfil, kplusp, ritzr, ndigit, - & '_naup2: Sorted real part of the eigenvalues') - call dvout (logfil, kplusp, ritzi, ndigit, - & '_naup2: Sorted imaginary part of the eigenvalues') - call dvout (logfil, kplusp, bounds, ndigit, - & '_naup2: Sorted ritz estimates.') - end if -c -c %------------------------------------% -c | Max iterations have been exceeded. | -c %------------------------------------% -c - if (iter .gt. mxiter .and. nconv .lt. numcnv) info = 1 -c -c %---------------------% -c | No shifts to apply. | -c %---------------------% -c - if (np .eq. 0 .and. nconv .lt. numcnv) info = 2 -c - np = nconv - go to 1100 -c - else if ( (nconv .lt. numcnv) .and. (ishift .eq. 1) ) then -c -c %-------------------------------------------------% -c | Do not have all the requested eigenvalues yet. | -c | To prevent possible stagnation, adjust the size | -c | of NEV. | -c %-------------------------------------------------% -c - nevbef = nev - nev = nev + min(nconv, np/2) - if (nev .eq. 1 .and. kplusp .ge. 6) then - nev = kplusp / 2 - else if (nev .eq. 1 .and. kplusp .gt. 3) then - nev = 2 - end if - np = kplusp - nev -c -c %---------------------------------------% -c | If the size of NEV was just increased | -c | resort the eigenvalues. | -c %---------------------------------------% -c - if (nevbef .lt. nev) - & call dngets (ishift, which, nev, np, ritzr, ritzi, - & bounds, workl, workl(np+1)) -c - end if -c - if (msglvl .gt. 0) then - call ivout (logfil, 1, nconv, ndigit, - & '_naup2: no. of "converged" Ritz values at this iter.') - if (msglvl .gt. 1) then - kp(1) = nev - kp(2) = np - call ivout (logfil, 2, kp, ndigit, - & '_naup2: NEV and NP are') - call dvout (logfil, nev, ritzr(np+1), ndigit, - & '_naup2: "wanted" Ritz values -- real part') - call dvout (logfil, nev, ritzi(np+1), ndigit, - & '_naup2: "wanted" Ritz values -- imag part') - call dvout (logfil, nev, bounds(np+1), ndigit, - & '_naup2: Ritz estimates of the "wanted" values ') - end if - end if -c - if (ishift .eq. 0) then -c -c %-------------------------------------------------------% -c | User specified shifts: reverse comminucation to | -c | compute the shifts. They are returned in the first | -c | 2*NP locations of WORKL. | -c %-------------------------------------------------------% -c - ushift = .true. - ido = 3 - go to 9000 - end if -c - 50 continue -c -c %------------------------------------% -c | Back from reverse communication; | -c | User specified shifts are returned | -c | in WORKL(1:2*NP) | -c %------------------------------------% -c - ushift = .false. -c - if ( ishift .eq. 0 ) then -c -c %----------------------------------% -c | Move the NP shifts from WORKL to | -c | RITZR, RITZI to free up WORKL | -c | for non-exact shift case. | -c %----------------------------------% -c - call dcopy (np, workl, 1, ritzr, 1) - call dcopy (np, workl(np+1), 1, ritzi, 1) - end if -c - if (msglvl .gt. 2) then - call ivout (logfil, 1, np, ndigit, - & '_naup2: The number of shifts to apply ') - call dvout (logfil, np, ritzr, ndigit, - & '_naup2: Real part of the shifts') - call dvout (logfil, np, ritzi, ndigit, - & '_naup2: Imaginary part of the shifts') - if ( ishift .eq. 1 ) - & call dvout (logfil, np, bounds, ndigit, - & '_naup2: Ritz estimates of the shifts') - end if -c -c %---------------------------------------------------------% -c | Apply the NP implicit shifts by QR bulge chasing. | -c | Each shift is applied to the whole upper Hessenberg | -c | matrix H. | -c | The first 2*N locations of WORKD are used as workspace. | -c %---------------------------------------------------------% -c - call dnapps (n, nev, np, ritzr, ritzi, v, ldv, - & h, ldh, resid, q, ldq, workl, workd) -c -c %---------------------------------------------% -c | Compute the B-norm of the updated residual. | -c | Keep B*RESID in WORKD(1:N) to be used in | -c | the first step of the next call to dnaitr . | -c %---------------------------------------------% -c - cnorm = .true. - call arscnd (t2) - if (bmat .eq. 'G') then - nbx = nbx + 1 - call dcopy (n, resid, 1, workd(n+1), 1) - ipntr(1) = n + 1 - ipntr(2) = 1 - ido = 2 -c -c %----------------------------------% -c | Exit in order to compute B*RESID | -c %----------------------------------% -c - go to 9000 - else if (bmat .eq. 'I') then - call dcopy (n, resid, 1, workd, 1) - end if -c - 100 continue -c -c %----------------------------------% -c | Back from reverse communication; | -c | WORKD(1:N) := B*RESID | -c %----------------------------------% -c - if (bmat .eq. 'G') then - call arscnd (t3) - tmvbx = tmvbx + (t3 - t2) - end if -c - if (bmat .eq. 'G') then - rnorm = ddot (n, resid, 1, workd, 1) - rnorm = sqrt(abs(rnorm)) - else if (bmat .eq. 'I') then - rnorm = dnrm2 (n, resid, 1) - end if - cnorm = .false. -c - if (msglvl .gt. 2) then - call dvout (logfil, 1, rnorm, ndigit, - & '_naup2: B-norm of residual for compressed factorization') - call dmout (logfil, nev, nev, h, ldh, ndigit, - & '_naup2: Compressed upper Hessenberg matrix H') - end if -c - go to 1000 -c -c %---------------------------------------------------------------% -c | | -c | E N D O F M A I N I T E R A T I O N L O O P | -c | | -c %---------------------------------------------------------------% -c - 1100 continue -c - mxiter = iter - nev = numcnv -c - 1200 continue - ido = 99 -c -c %------------% -c | Error Exit | -c %------------% -c - call arscnd (t1) - tnaup2 = t1 - t0 -c - 9000 continue -c -c %---------------% -c | End of dnaup2 | -c %---------------% -c - return - end
--- a/libcruft/arpack/src/dnaupd.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,693 +0,0 @@ -c\BeginDoc -c -c\Name: dnaupd -c -c\Description: -c Reverse communication interface for the Implicitly Restarted Arnoldi -c iteration. This subroutine computes approximations to a few eigenpairs -c of a linear operator "OP" with respect to a semi-inner product defined by -c a symmetric positive semi-definite real matrix B. B may be the identity -c matrix. NOTE: If the linear operator "OP" is real and symmetric -c with respect to the real positive semi-definite symmetric matrix B, -c i.e. B*OP = (OP`)*B, then subroutine dsaupd should be used instead. -c -c The computed approximate eigenvalues are called Ritz values and -c the corresponding approximate eigenvectors are called Ritz vectors. -c -c dnaupd is usually called iteratively to solve one of the -c following problems: -c -c Mode 1: A*x = lambda*x. -c ===> OP = A and B = I. -c -c Mode 2: A*x = lambda*M*x, M symmetric positive definite -c ===> OP = inv[M]*A and B = M. -c ===> (If M can be factored see remark 3 below) -c -c Mode 3: A*x = lambda*M*x, M symmetric semi-definite -c ===> OP = Real_Part{ inv[A - sigma*M]*M } and B = M. -c ===> shift-and-invert mode (in real arithmetic) -c If OP*x = amu*x, then -c amu = 1/2 * [ 1/(lambda-sigma) + 1/(lambda-conjg(sigma)) ]. -c Note: If sigma is real, i.e. imaginary part of sigma is zero; -c Real_Part{ inv[A - sigma*M]*M } == inv[A - sigma*M]*M -c amu == 1/(lambda-sigma). -c -c Mode 4: A*x = lambda*M*x, M symmetric semi-definite -c ===> OP = Imaginary_Part{ inv[A - sigma*M]*M } and B = M. -c ===> shift-and-invert mode (in real arithmetic) -c If OP*x = amu*x, then -c amu = 1/2i * [ 1/(lambda-sigma) - 1/(lambda-conjg(sigma)) ]. -c -c Both mode 3 and 4 give the same enhancement to eigenvalues close to -c the (complex) shift sigma. However, as lambda goes to infinity, -c the operator OP in mode 4 dampens the eigenvalues more strongly than -c does OP defined in mode 3. -c -c NOTE: The action of w <- inv[A - sigma*M]*v or w <- inv[M]*v -c should be accomplished either by a direct method -c using a sparse matrix factorization and solving -c -c [A - sigma*M]*w = v or M*w = v, -c -c or through an iterative method for solving these -c systems. If an iterative method is used, the -c convergence test must be more stringent than -c the accuracy requirements for the eigenvalue -c approximations. -c -c\Usage: -c call dnaupd -c ( IDO, BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, -c IPNTR, WORKD, WORKL, LWORKL, INFO ) -c -c\Arguments -c IDO Integer. (INPUT/OUTPUT) -c Reverse communication flag. IDO must be zero on the first -c call to dnaupd . IDO will be set internally to -c indicate the type of operation to be performed. Control is -c then given back to the calling routine which has the -c responsibility to carry out the requested operation and call -c dnaupd with the result. The operand is given in -c WORKD(IPNTR(1)), the result must be put in WORKD(IPNTR(2)). -c ------------------------------------------------------------- -c IDO = 0: first call to the reverse communication interface -c IDO = -1: compute Y = OP * X where -c IPNTR(1) is the pointer into WORKD for X, -c IPNTR(2) is the pointer into WORKD for Y. -c This is for the initialization phase to force the -c starting vector into the range of OP. -c IDO = 1: compute Y = OP * X where -c IPNTR(1) is the pointer into WORKD for X, -c IPNTR(2) is the pointer into WORKD for Y. -c In mode 3 and 4, the vector B * X is already -c available in WORKD(ipntr(3)). It does not -c need to be recomputed in forming OP * X. -c IDO = 2: compute Y = B * X where -c IPNTR(1) is the pointer into WORKD for X, -c IPNTR(2) is the pointer into WORKD for Y. -c IDO = 3: compute the IPARAM(8) real and imaginary parts -c of the shifts where INPTR(14) is the pointer -c into WORKL for placing the shifts. See Remark -c 5 below. -c IDO = 99: done -c ------------------------------------------------------------- -c -c BMAT Character*1. (INPUT) -c BMAT specifies the type of the matrix B that defines the -c semi-inner product for the operator OP. -c BMAT = 'I' -> standard eigenvalue problem A*x = lambda*x -c BMAT = 'G' -> generalized eigenvalue problem A*x = lambda*B*x -c -c N Integer. (INPUT) -c Dimension of the eigenproblem. -c -c WHICH Character*2. (INPUT) -c 'LM' -> want the NEV eigenvalues of largest magnitude. -c 'SM' -> want the NEV eigenvalues of smallest magnitude. -c 'LR' -> want the NEV eigenvalues of largest real part. -c 'SR' -> want the NEV eigenvalues of smallest real part. -c 'LI' -> want the NEV eigenvalues of largest imaginary part. -c 'SI' -> want the NEV eigenvalues of smallest imaginary part. -c -c NEV Integer. (INPUT) -c Number of eigenvalues of OP to be computed. 0 < NEV < N-1. -c -c TOL Double precision scalar. (INPUT) -c Stopping criterion: the relative accuracy of the Ritz value -c is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I)) -c where ABS(RITZ(I)) is the magnitude when RITZ(I) is complex. -c DEFAULT = DLAMCH ('EPS') (machine precision as computed -c by the LAPACK auxiliary subroutine DLAMCH ). -c -c RESID Double precision array of length N. (INPUT/OUTPUT) -c On INPUT: -c If INFO .EQ. 0, a random initial residual vector is used. -c If INFO .NE. 0, RESID contains the initial residual vector, -c possibly from a previous run. -c On OUTPUT: -c RESID contains the final residual vector. -c -c NCV Integer. (INPUT) -c Number of columns of the matrix V. NCV must satisfy the two -c inequalities 2 <= NCV-NEV and NCV <= N. -c This will indicate how many Arnoldi vectors are generated -c at each iteration. After the startup phase in which NEV -c Arnoldi vectors are generated, the algorithm generates -c approximately NCV-NEV Arnoldi vectors at each subsequent update -c iteration. Most of the cost in generating each Arnoldi vector is -c in the matrix-vector operation OP*x. -c NOTE: 2 <= NCV-NEV in order that complex conjugate pairs of Ritz -c values are kept together. (See remark 4 below) -c -c V Double precision array N by NCV. (OUTPUT) -c Contains the final set of Arnoldi basis vectors. -c -c LDV Integer. (INPUT) -c Leading dimension of V exactly as declared in the calling program. -c -c IPARAM Integer array of length 11. (INPUT/OUTPUT) -c IPARAM(1) = ISHIFT: method for selecting the implicit shifts. -c The shifts selected at each iteration are used to restart -c the Arnoldi iteration in an implicit fashion. -c ------------------------------------------------------------- -c ISHIFT = 0: the shifts are provided by the user via -c reverse communication. The real and imaginary -c parts of the NCV eigenvalues of the Hessenberg -c matrix H are returned in the part of the WORKL -c array corresponding to RITZR and RITZI. See remark -c 5 below. -c ISHIFT = 1: exact shifts with respect to the current -c Hessenberg matrix H. This is equivalent to -c restarting the iteration with a starting vector -c that is a linear combination of approximate Schur -c vectors associated with the "wanted" Ritz values. -c ------------------------------------------------------------- -c -c IPARAM(2) = No longer referenced. -c -c IPARAM(3) = MXITER -c On INPUT: maximum number of Arnoldi update iterations allowed. -c On OUTPUT: actual number of Arnoldi update iterations taken. -c -c IPARAM(4) = NB: blocksize to be used in the recurrence. -c The code currently works only for NB = 1. -c -c IPARAM(5) = NCONV: number of "converged" Ritz values. -c This represents the number of Ritz values that satisfy -c the convergence criterion. -c -c IPARAM(6) = IUPD -c No longer referenced. Implicit restarting is ALWAYS used. -c -c IPARAM(7) = MODE -c On INPUT determines what type of eigenproblem is being solved. -c Must be 1,2,3,4; See under \Description of dnaupd for the -c four modes available. -c -c IPARAM(8) = NP -c When ido = 3 and the user provides shifts through reverse -c communication (IPARAM(1)=0), dnaupd returns NP, the number -c of shifts the user is to provide. 0 < NP <=NCV-NEV. See Remark -c 5 below. -c -c IPARAM(9) = NUMOP, IPARAM(10) = NUMOPB, IPARAM(11) = NUMREO, -c OUTPUT: NUMOP = total number of OP*x operations, -c NUMOPB = total number of B*x operations if BMAT='G', -c NUMREO = total number of steps of re-orthogonalization. -c -c IPNTR Integer array of length 14. (OUTPUT) -c Pointer to mark the starting locations in the WORKD and WORKL -c arrays for matrices/vectors used by the Arnoldi iteration. -c ------------------------------------------------------------- -c IPNTR(1): pointer to the current operand vector X in WORKD. -c IPNTR(2): pointer to the current result vector Y in WORKD. -c IPNTR(3): pointer to the vector B * X in WORKD when used in -c the shift-and-invert mode. -c IPNTR(4): pointer to the next available location in WORKL -c that is untouched by the program. -c IPNTR(5): pointer to the NCV by NCV upper Hessenberg matrix -c H in WORKL. -c IPNTR(6): pointer to the real part of the ritz value array -c RITZR in WORKL. -c IPNTR(7): pointer to the imaginary part of the ritz value array -c RITZI in WORKL. -c IPNTR(8): pointer to the Ritz estimates in array WORKL associated -c with the Ritz values located in RITZR and RITZI in WORKL. -c -c IPNTR(14): pointer to the NP shifts in WORKL. See Remark 5 below. -c -c Note: IPNTR(9:13) is only referenced by dneupd . See Remark 2 below. -c -c IPNTR(9): pointer to the real part of the NCV RITZ values of the -c original system. -c IPNTR(10): pointer to the imaginary part of the NCV RITZ values of -c the original system. -c IPNTR(11): pointer to the NCV corresponding error bounds. -c IPNTR(12): pointer to the NCV by NCV upper quasi-triangular -c Schur matrix for H. -c IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors -c of the upper Hessenberg matrix H. Only referenced by -c dneupd if RVEC = .TRUE. See Remark 2 below. -c ------------------------------------------------------------- -c -c WORKD Double precision work array of length 3*N. (REVERSE COMMUNICATION) -c Distributed array to be used in the basic Arnoldi iteration -c for reverse communication. The user should not use WORKD -c as temporary workspace during the iteration. Upon termination -c WORKD(1:N) contains B*RESID(1:N). If an invariant subspace -c associated with the converged Ritz values is desired, see remark -c 2 below, subroutine dneupd uses this output. -c See Data Distribution Note below. -c -c WORKL Double precision work array of length LWORKL. (OUTPUT/WORKSPACE) -c Private (replicated) array on each PE or array allocated on -c the front end. See Data Distribution Note below. -c -c LWORKL Integer. (INPUT) -c LWORKL must be at least 3*NCV**2 + 6*NCV. -c -c INFO Integer. (INPUT/OUTPUT) -c If INFO .EQ. 0, a randomly initial residual vector is used. -c If INFO .NE. 0, RESID contains the initial residual vector, -c possibly from a previous run. -c Error flag on output. -c = 0: Normal exit. -c = 1: Maximum number of iterations taken. -c All possible eigenvalues of OP has been found. IPARAM(5) -c returns the number of wanted converged Ritz values. -c = 2: No longer an informational error. Deprecated starting -c with release 2 of ARPACK. -c = 3: No shifts could be applied during a cycle of the -c Implicitly restarted Arnoldi iteration. One possibility -c is to increase the size of NCV relative to NEV. -c See remark 4 below. -c = -1: N must be positive. -c = -2: NEV must be positive. -c = -3: NCV-NEV >= 2 and less than or equal to N. -c = -4: The maximum number of Arnoldi update iteration -c must be greater than zero. -c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI' -c = -6: BMAT must be one of 'I' or 'G'. -c = -7: Length of private work array is not sufficient. -c = -8: Error return from LAPACK eigenvalue calculation; -c = -9: Starting vector is zero. -c = -10: IPARAM(7) must be 1,2,3,4. -c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatable. -c = -12: IPARAM(1) must be equal to 0 or 1. -c = -9999: Could not build an Arnoldi factorization. -c IPARAM(5) returns the size of the current Arnoldi -c factorization. -c -c\Remarks -c 1. The computed Ritz values are approximate eigenvalues of OP. The -c selection of WHICH should be made with this in mind when -c Mode = 3 and 4. After convergence, approximate eigenvalues of the -c original problem may be obtained with the ARPACK subroutine dneupd . -c -c 2. If a basis for the invariant subspace corresponding to the converged Ritz -c values is needed, the user must call dneupd immediately following -c completion of dnaupd . This is new starting with release 2 of ARPACK. -c -c 3. If M can be factored into a Cholesky factorization M = LL` -c then Mode = 2 should not be selected. Instead one should use -c Mode = 1 with OP = inv(L)*A*inv(L`). Appropriate triangular -c linear systems should be solved with L and L` rather -c than computing inverses. After convergence, an approximate -c eigenvector z of the original problem is recovered by solving -c L`z = x where x is a Ritz vector of OP. -c -c 4. At present there is no a-priori analysis to guide the selection -c of NCV relative to NEV. The only formal requrement is that NCV > NEV + 2. -c However, it is recommended that NCV .ge. 2*NEV+1. If many problems of -c the same type are to be solved, one should experiment with increasing -c NCV while keeping NEV fixed for a given test problem. This will -c usually decrease the required number of OP*x operations but it -c also increases the work and storage required to maintain the orthogonal -c basis vectors. The optimal "cross-over" with respect to CPU time -c is problem dependent and must be determined empirically. -c See Chapter 8 of Reference 2 for further information. -c -c 5. When IPARAM(1) = 0, and IDO = 3, the user needs to provide the -c NP = IPARAM(8) real and imaginary parts of the shifts in locations -c real part imaginary part -c ----------------------- -------------- -c 1 WORKL(IPNTR(14)) WORKL(IPNTR(14)+NP) -c 2 WORKL(IPNTR(14)+1) WORKL(IPNTR(14)+NP+1) -c . . -c . . -c . . -c NP WORKL(IPNTR(14)+NP-1) WORKL(IPNTR(14)+2*NP-1). -c -c Only complex conjugate pairs of shifts may be applied and the pairs -c must be placed in consecutive locations. The real part of the -c eigenvalues of the current upper Hessenberg matrix are located in -c WORKL(IPNTR(6)) through WORKL(IPNTR(6)+NCV-1) and the imaginary part -c in WORKL(IPNTR(7)) through WORKL(IPNTR(7)+NCV-1). They are ordered -c according to the order defined by WHICH. The complex conjugate -c pairs are kept together and the associated Ritz estimates are located in -c WORKL(IPNTR(8)), WORKL(IPNTR(8)+1), ... , WORKL(IPNTR(8)+NCV-1). -c -c----------------------------------------------------------------------- -c -c\Data Distribution Note: -c -c Fortran-D syntax: -c ================ -c Double precision resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) -c decompose d1(n), d2(n,ncv) -c align resid(i) with d1(i) -c align v(i,j) with d2(i,j) -c align workd(i) with d1(i) range (1:n) -c align workd(i) with d1(i-n) range (n+1:2*n) -c align workd(i) with d1(i-2*n) range (2*n+1:3*n) -c distribute d1(block), d2(block,:) -c replicated workl(lworkl) -c -c Cray MPP syntax: -c =============== -c Double precision resid(n), v(ldv,ncv), workd(n,3), workl(lworkl) -c shared resid(block), v(block,:), workd(block,:) -c replicated workl(lworkl) -c -c CM2/CM5 syntax: -c ============== -c -c----------------------------------------------------------------------- -c -c include 'ex-nonsym.doc' -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Local variables: -c xxxxxx real -c -c\References: -c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in -c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), -c pp 357-385. -c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly -c Restarted Arnoldi Iteration", Rice University Technical Report -c TR95-13, Department of Computational and Applied Mathematics. -c 3. B.N. Parlett & Y. Saad, "Complex Shift and Invert Strategies for -c Real Matrices", Linear Algebra and its Applications, vol 88/89, -c pp 575-595, (1987). -c -c\Routines called: -c dnaup2 ARPACK routine that implements the Implicitly Restarted -c Arnoldi Iteration. -c ivout ARPACK utility routine that prints integers. -c arscnd ARPACK utility routine for timing. -c dvout ARPACK utility routine that prints vectors. -c dlamch LAPACK routine that determines machine constants. -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\Revision history: -c 12/16/93: Version '1.1' -c -c\SCCS Information: @(#) -c FILE: naupd.F SID: 2.8 DATE OF SID: 04/10/01 RELEASE: 2 -c -c\Remarks -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine dnaupd - & ( ido, bmat, n, which, nev, tol, resid, ncv, v, ldv, iparam, - & ipntr, workd, workl, lworkl, info ) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - character bmat*1, which*2 - integer ido, info, ldv, lworkl, n, ncv, nev - Double precision - & tol -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - integer iparam(11), ipntr(14) - Double precision - & resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) -c -c %------------% -c | Parameters | -c %------------% -c - Double precision - & one, zero - parameter (one = 1.0D+0 , zero = 0.0D+0 ) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - integer bounds, ierr, ih, iq, ishift, iupd, iw, - & ldh, ldq, levec, mode, msglvl, mxiter, nb, - & nev0, next, np, ritzi, ritzr, j - save bounds, ih, iq, ishift, iupd, iw, ldh, ldq, - & levec, mode, msglvl, mxiter, nb, nev0, next, - & np, ritzi, ritzr -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external dnaup2 , dvout , ivout, arscnd, dstatn -c -c %--------------------% -c | External Functions | -c %--------------------% -c - Double precision - & dlamch - external dlamch -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c - if (ido .eq. 0) then -c -c %-------------------------------% -c | Initialize timing statistics | -c | & message level for debugging | -c %-------------------------------% -c - call dstatn - call arscnd (t0) - msglvl = mnaupd -c -c %----------------% -c | Error checking | -c %----------------% -c - ierr = 0 - ishift = iparam(1) -c levec = iparam(2) - mxiter = iparam(3) -c nb = iparam(4) - nb = 1 -c -c %--------------------------------------------% -c | Revision 2 performs only implicit restart. | -c %--------------------------------------------% -c - iupd = 1 - mode = iparam(7) -c - if (n .le. 0) then - ierr = -1 - else if (nev .le. 0) then - ierr = -2 - else if (ncv .le. nev+1 .or. ncv .gt. n) then - ierr = -3 - else if (mxiter .le. 0) then - ierr = -4 - else if (which .ne. 'LM' .and. - & which .ne. 'SM' .and. - & which .ne. 'LR' .and. - & which .ne. 'SR' .and. - & which .ne. 'LI' .and. - & which .ne. 'SI') then - ierr = -5 - else if (bmat .ne. 'I' .and. bmat .ne. 'G') then - ierr = -6 - else if (lworkl .lt. 3*ncv**2 + 6*ncv) then - ierr = -7 - else if (mode .lt. 1 .or. mode .gt. 4) then - ierr = -10 - else if (mode .eq. 1 .and. bmat .eq. 'G') then - ierr = -11 - else if (ishift .lt. 0 .or. ishift .gt. 1) then - ierr = -12 - end if -c -c %------------% -c | Error Exit | -c %------------% -c - if (ierr .ne. 0) then - info = ierr - ido = 99 - go to 9000 - end if -c -c %------------------------% -c | Set default parameters | -c %------------------------% -c - if (nb .le. 0) nb = 1 - if (tol .le. zero) tol = dlamch ('EpsMach') -c -c %----------------------------------------------% -c | NP is the number of additional steps to | -c | extend the length NEV Lanczos factorization. | -c | NEV0 is the local variable designating the | -c | size of the invariant subspace desired. | -c %----------------------------------------------% -c - np = ncv - nev - nev0 = nev -c -c %-----------------------------% -c | Zero out internal workspace | -c %-----------------------------% -c - do 10 j = 1, 3*ncv**2 + 6*ncv - workl(j) = zero - 10 continue -c -c %-------------------------------------------------------------% -c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | -c | etc... and the remaining workspace. | -c | Also update pointer to be used on output. | -c | Memory is laid out as follows: | -c | workl(1:ncv*ncv) := generated Hessenberg matrix | -c | workl(ncv*ncv+1:ncv*ncv+2*ncv) := real and imaginary | -c | parts of ritz values | -c | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := error bounds | -c | workl(ncv*ncv+3*ncv+1:2*ncv*ncv+3*ncv) := rotation matrix Q | -c | workl(2*ncv*ncv+3*ncv+1:3*ncv*ncv+6*ncv) := workspace | -c | The final workspace is needed by subroutine dneigh called | -c | by dnaup2 . Subroutine dneigh calls LAPACK routines for | -c | calculating eigenvalues and the last row of the eigenvector | -c | matrix. | -c %-------------------------------------------------------------% -c - ldh = ncv - ldq = ncv - ih = 1 - ritzr = ih + ldh*ncv - ritzi = ritzr + ncv - bounds = ritzi + ncv - iq = bounds + ncv - iw = iq + ldq*ncv - next = iw + ncv**2 + 3*ncv -c - ipntr(4) = next - ipntr(5) = ih - ipntr(6) = ritzr - ipntr(7) = ritzi - ipntr(8) = bounds - ipntr(14) = iw -c - end if -c -c %-------------------------------------------------------% -c | Carry out the Implicitly restarted Arnoldi Iteration. | -c %-------------------------------------------------------% -c - call dnaup2 - & ( ido, bmat, n, which, nev0, np, tol, resid, mode, iupd, - & ishift, mxiter, v, ldv, workl(ih), ldh, workl(ritzr), - & workl(ritzi), workl(bounds), workl(iq), ldq, workl(iw), - & ipntr, workd, info ) -c -c %--------------------------------------------------% -c | ido .ne. 99 implies use of reverse communication | -c | to compute operations involving OP or shifts. | -c %--------------------------------------------------% -c - if (ido .eq. 3) iparam(8) = np - if (ido .ne. 99) go to 9000 -c - iparam(3) = mxiter - iparam(5) = np - iparam(9) = nopx - iparam(10) = nbx - iparam(11) = nrorth -c -c %------------------------------------% -c | Exit if there was an informational | -c | error within dnaup2 . | -c %------------------------------------% -c - if (info .lt. 0) go to 9000 - if (info .eq. 2) info = 3 -c - if (msglvl .gt. 0) then - call ivout (logfil, 1, mxiter, ndigit, - & '_naupd: Number of update iterations taken') - call ivout (logfil, 1, np, ndigit, - & '_naupd: Number of wanted "converged" Ritz values') - call dvout (logfil, np, workl(ritzr), ndigit, - & '_naupd: Real part of the final Ritz values') - call dvout (logfil, np, workl(ritzi), ndigit, - & '_naupd: Imaginary part of the final Ritz values') - call dvout (logfil, np, workl(bounds), ndigit, - & '_naupd: Associated Ritz estimates') - end if -c - call arscnd (t1) - tnaupd = t1 - t0 -c - if (msglvl .gt. 0) then -c -c %--------------------------------------------------------% -c | Version Number & Version Date are defined in version.h | -c %--------------------------------------------------------% -c - write (6,1000) - write (6,1100) mxiter, nopx, nbx, nrorth, nitref, nrstrt, - & tmvopx, tmvbx, tnaupd, tnaup2, tnaitr, titref, - & tgetv0, tneigh, tngets, tnapps, tnconv, trvec - 1000 format (//, - & 5x, '=============================================',/ - & 5x, '= Nonsymmetric implicit Arnoldi update code =',/ - & 5x, '= Version Number: ', ' 2.4' , 21x, ' =',/ - & 5x, '= Version Date: ', ' 07/31/96' , 16x, ' =',/ - & 5x, '=============================================',/ - & 5x, '= Summary of timing statistics =',/ - & 5x, '=============================================',//) - 1100 format ( - & 5x, 'Total number update iterations = ', i5,/ - & 5x, 'Total number of OP*x operations = ', i5,/ - & 5x, 'Total number of B*x operations = ', i5,/ - & 5x, 'Total number of reorthogonalization steps = ', i5,/ - & 5x, 'Total number of iterative refinement steps = ', i5,/ - & 5x, 'Total number of restart steps = ', i5,/ - & 5x, 'Total time in user OP*x operation = ', f12.6,/ - & 5x, 'Total time in user B*x operation = ', f12.6,/ - & 5x, 'Total time in Arnoldi update routine = ', f12.6,/ - & 5x, 'Total time in naup2 routine = ', f12.6,/ - & 5x, 'Total time in basic Arnoldi iteration loop = ', f12.6,/ - & 5x, 'Total time in reorthogonalization phase = ', f12.6,/ - & 5x, 'Total time in (re)start vector generation = ', f12.6,/ - & 5x, 'Total time in Hessenberg eig. subproblem = ', f12.6,/ - & 5x, 'Total time in getting the shifts = ', f12.6,/ - & 5x, 'Total time in applying the shifts = ', f12.6,/ - & 5x, 'Total time in convergence testing = ', f12.6,/ - & 5x, 'Total time in computing final Ritz vectors = ', f12.6/) - end if -c - 9000 continue -c - return -c -c %---------------% -c | End of dnaupd | -c %---------------% -c - end
--- a/libcruft/arpack/src/dnconv.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,146 +0,0 @@ -c----------------------------------------------------------------------- -c\BeginDoc -c -c\Name: dnconv -c -c\Description: -c Convergence testing for the nonsymmetric Arnoldi eigenvalue routine. -c -c\Usage: -c call dnconv -c ( N, RITZR, RITZI, BOUNDS, TOL, NCONV ) -c -c\Arguments -c N Integer. (INPUT) -c Number of Ritz values to check for convergence. -c -c RITZR, Double precision arrays of length N. (INPUT) -c RITZI Real and imaginary parts of the Ritz values to be checked -c for convergence. - -c BOUNDS Double precision array of length N. (INPUT) -c Ritz estimates for the Ritz values in RITZR and RITZI. -c -c TOL Double precision scalar. (INPUT) -c Desired backward error for a Ritz value to be considered -c "converged". -c -c NCONV Integer scalar. (OUTPUT) -c Number of "converged" Ritz values. -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Local variables: -c xxxxxx real -c -c\Routines called: -c arscnd ARPACK utility routine for timing. -c dlamch LAPACK routine that determines machine constants. -c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\Revision history: -c xx/xx/92: Version ' 2.1' -c -c\SCCS Information: @(#) -c FILE: nconv.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2 -c -c\Remarks -c 1. xxxx -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine dnconv (n, ritzr, ritzi, bounds, tol, nconv) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - integer n, nconv - Double precision - & tol -c -c %-----------------% -c | Array Arguments | -c %-----------------% - - Double precision - & ritzr(n), ritzi(n), bounds(n) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - integer i - Double precision - & temp, eps23 -c -c %--------------------% -c | External Functions | -c %--------------------% -c - Double precision - & dlapy2, dlamch - external dlapy2, dlamch - -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c -c %-------------------------------------------------------------% -c | Convergence test: unlike in the symmetric code, I am not | -c | using things like refined error bounds and gap condition | -c | because I don't know the exact equivalent concept. | -c | | -c | Instead the i-th Ritz value is considered "converged" when: | -c | | -c | bounds(i) .le. ( TOL * | ritz | ) | -c | | -c | for some appropriate choice of norm. | -c %-------------------------------------------------------------% -c - call arscnd (t0) -c -c %---------------------------------% -c | Get machine dependent constant. | -c %---------------------------------% -c - eps23 = dlamch('Epsilon-Machine') - eps23 = eps23**(2.0D+0 / 3.0D+0) -c - nconv = 0 - do 20 i = 1, n - temp = max( eps23, dlapy2( ritzr(i), ritzi(i) ) ) - if (bounds(i) .le. tol*temp) nconv = nconv + 1 - 20 continue -c - call arscnd (t1) - tnconv = tnconv + (t1 - t0) -c - return -c -c %---------------% -c | End of dnconv | -c %---------------% -c - end
--- a/libcruft/arpack/src/dneigh.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,314 +0,0 @@ -c----------------------------------------------------------------------- -c\BeginDoc -c -c\Name: dneigh -c -c\Description: -c Compute the eigenvalues of the current upper Hessenberg matrix -c and the corresponding Ritz estimates given the current residual norm. -c -c\Usage: -c call dneigh -c ( RNORM, N, H, LDH, RITZR, RITZI, BOUNDS, Q, LDQ, WORKL, IERR ) -c -c\Arguments -c RNORM Double precision scalar. (INPUT) -c Residual norm corresponding to the current upper Hessenberg -c matrix H. -c -c N Integer. (INPUT) -c Size of the matrix H. -c -c H Double precision N by N array. (INPUT) -c H contains the current upper Hessenberg matrix. -c -c LDH Integer. (INPUT) -c Leading dimension of H exactly as declared in the calling -c program. -c -c RITZR, Double precision arrays of length N. (OUTPUT) -c RITZI On output, RITZR(1:N) (resp. RITZI(1:N)) contains the real -c (respectively imaginary) parts of the eigenvalues of H. -c -c BOUNDS Double precision array of length N. (OUTPUT) -c On output, BOUNDS contains the Ritz estimates associated with -c the eigenvalues RITZR and RITZI. This is equal to RNORM -c times the last components of the eigenvectors corresponding -c to the eigenvalues in RITZR and RITZI. -c -c Q Double precision N by N array. (WORKSPACE) -c Workspace needed to store the eigenvectors of H. -c -c LDQ Integer. (INPUT) -c Leading dimension of Q exactly as declared in the calling -c program. -c -c WORKL Double precision work array of length N**2 + 3*N. (WORKSPACE) -c Private (replicated) array on each PE or array allocated on -c the front end. This is needed to keep the full Schur form -c of H and also in the calculation of the eigenvectors of H. -c -c IERR Integer. (OUTPUT) -c Error exit flag from dlaqrb or dtrevc. -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Local variables: -c xxxxxx real -c -c\Routines called: -c dlaqrb ARPACK routine to compute the real Schur form of an -c upper Hessenberg matrix and last row of the Schur vectors. -c arscnd ARPACK utility routine for timing. -c dmout ARPACK utility routine that prints matrices -c dvout ARPACK utility routine that prints vectors. -c dlacpy LAPACK matrix copy routine. -c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. -c dtrevc LAPACK routine to compute the eigenvectors of a matrix -c in upper quasi-triangular form -c dgemv Level 2 BLAS routine for matrix vector multiplication. -c dcopy Level 1 BLAS that copies one vector to another . -c dnrm2 Level 1 BLAS that computes the norm of a vector. -c dscal Level 1 BLAS that scales a vector. -c -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\Revision history: -c xx/xx/92: Version ' 2.1' -c -c\SCCS Information: @(#) -c FILE: neigh.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2 -c -c\Remarks -c None -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine dneigh (rnorm, n, h, ldh, ritzr, ritzi, bounds, - & q, ldq, workl, ierr) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - integer ierr, n, ldh, ldq - Double precision - & rnorm -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - Double precision - & bounds(n), h(ldh,n), q(ldq,n), ritzi(n), ritzr(n), - & workl(n*(n+3)) -c -c %------------% -c | Parameters | -c %------------% -c - Double precision - & one, zero - parameter (one = 1.0D+0, zero = 0.0D+0) -c -c %------------------------% -c | Local Scalars & Arrays | -c %------------------------% -c - logical select(1) - integer i, iconj, msglvl - Double precision - & temp, vl(1) -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external dcopy, dlacpy, dlaqrb, dtrevc, dvout, arscnd -c -c %--------------------% -c | External Functions | -c %--------------------% -c - Double precision - & dlapy2, dnrm2 - external dlapy2, dnrm2 -c -c %---------------------% -c | Intrinsic Functions | -c %---------------------% -c - intrinsic abs -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c -c -c %-------------------------------% -c | Initialize timing statistics | -c | & message level for debugging | -c %-------------------------------% -c - call arscnd (t0) - msglvl = mneigh -c - if (msglvl .gt. 2) then - call dmout (logfil, n, n, h, ldh, ndigit, - & '_neigh: Entering upper Hessenberg matrix H ') - end if -c -c %-----------------------------------------------------------% -c | 1. Compute the eigenvalues, the last components of the | -c | corresponding Schur vectors and the full Schur form T | -c | of the current upper Hessenberg matrix H. | -c | dlaqrb returns the full Schur form of H in WORKL(1:N**2) | -c | and the last components of the Schur vectors in BOUNDS. | -c %-----------------------------------------------------------% -c - call dlacpy ('All', n, n, h, ldh, workl, n) - call dlaqrb (.true., n, 1, n, workl, n, ritzr, ritzi, bounds, - & ierr) - if (ierr .ne. 0) go to 9000 -c - if (msglvl .gt. 1) then - call dvout (logfil, n, bounds, ndigit, - & '_neigh: last row of the Schur matrix for H') - end if -c -c %-----------------------------------------------------------% -c | 2. Compute the eigenvectors of the full Schur form T and | -c | apply the last components of the Schur vectors to get | -c | the last components of the corresponding eigenvectors. | -c | Remember that if the i-th and (i+1)-st eigenvalues are | -c | complex conjugate pairs, then the real & imaginary part | -c | of the eigenvector components are split across adjacent | -c | columns of Q. | -c %-----------------------------------------------------------% -c - call dtrevc ('R', 'A', select, n, workl, n, vl, n, q, ldq, - & n, n, workl(n*n+1), ierr) -c - if (ierr .ne. 0) go to 9000 -c -c %------------------------------------------------% -c | Scale the returning eigenvectors so that their | -c | euclidean norms are all one. LAPACK subroutine | -c | dtrevc returns each eigenvector normalized so | -c | that the element of largest magnitude has | -c | magnitude 1; here the magnitude of a complex | -c | number (x,y) is taken to be |x| + |y|. | -c %------------------------------------------------% -c - iconj = 0 - do 10 i=1, n - if ( abs( ritzi(i) ) .le. zero ) then -c -c %----------------------% -c | Real eigenvalue case | -c %----------------------% -c - temp = dnrm2( n, q(1,i), 1 ) - call dscal ( n, one / temp, q(1,i), 1 ) - else -c -c %-------------------------------------------% -c | Complex conjugate pair case. Note that | -c | since the real and imaginary part of | -c | the eigenvector are stored in consecutive | -c | columns, we further normalize by the | -c | square root of two. | -c %-------------------------------------------% -c - if (iconj .eq. 0) then - temp = dlapy2( dnrm2( n, q(1,i), 1 ), - & dnrm2( n, q(1,i+1), 1 ) ) - call dscal ( n, one / temp, q(1,i), 1 ) - call dscal ( n, one / temp, q(1,i+1), 1 ) - iconj = 1 - else - iconj = 0 - end if - end if - 10 continue -c - call dgemv ('T', n, n, one, q, ldq, bounds, 1, zero, workl, 1) -c - if (msglvl .gt. 1) then - call dvout (logfil, n, workl, ndigit, - & '_neigh: Last row of the eigenvector matrix for H') - end if -c -c %----------------------------% -c | Compute the Ritz estimates | -c %----------------------------% -c - iconj = 0 - do 20 i = 1, n - if ( abs( ritzi(i) ) .le. zero ) then -c -c %----------------------% -c | Real eigenvalue case | -c %----------------------% -c - bounds(i) = rnorm * abs( workl(i) ) - else -c -c %-------------------------------------------% -c | Complex conjugate pair case. Note that | -c | since the real and imaginary part of | -c | the eigenvector are stored in consecutive | -c | columns, we need to take the magnitude | -c | of the last components of the two vectors | -c %-------------------------------------------% -c - if (iconj .eq. 0) then - bounds(i) = rnorm * dlapy2( workl(i), workl(i+1) ) - bounds(i+1) = bounds(i) - iconj = 1 - else - iconj = 0 - end if - end if - 20 continue -c - if (msglvl .gt. 2) then - call dvout (logfil, n, ritzr, ndigit, - & '_neigh: Real part of the eigenvalues of H') - call dvout (logfil, n, ritzi, ndigit, - & '_neigh: Imaginary part of the eigenvalues of H') - call dvout (logfil, n, bounds, ndigit, - & '_neigh: Ritz estimates for the eigenvalues of H') - end if -c - call arscnd (t1) - tneigh = tneigh + (t1 - t0) -c - 9000 continue - return -c -c %---------------% -c | End of dneigh | -c %---------------% -c - end
--- a/libcruft/arpack/src/dneupd.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1068 +0,0 @@ -c\BeginDoc -c -c\Name: dneupd -c -c\Description: -c -c This subroutine returns the converged approximations to eigenvalues -c of A*z = lambda*B*z and (optionally): -c -c (1) The corresponding approximate eigenvectors; -c -c (2) An orthonormal basis for the associated approximate -c invariant subspace; -c -c (3) Both. -c -c There is negligible additional cost to obtain eigenvectors. An orthonormal -c basis is always computed. There is an additional storage cost of n*nev -c if both are requested (in this case a separate array Z must be supplied). -c -c The approximate eigenvalues and eigenvectors of A*z = lambda*B*z -c are derived from approximate eigenvalues and eigenvectors of -c of the linear operator OP prescribed by the MODE selection in the -c call to DNAUPD . DNAUPD must be called before this routine is called. -c These approximate eigenvalues and vectors are commonly called Ritz -c values and Ritz vectors respectively. They are referred to as such -c in the comments that follow. The computed orthonormal basis for the -c invariant subspace corresponding to these Ritz values is referred to as a -c Schur basis. -c -c See documentation in the header of the subroutine DNAUPD for -c definition of OP as well as other terms and the relation of computed -c Ritz values and Ritz vectors of OP with respect to the given problem -c A*z = lambda*B*z. For a brief description, see definitions of -c IPARAM(7), MODE and WHICH in the documentation of DNAUPD . -c -c\Usage: -c call dneupd -c ( RVEC, HOWMNY, SELECT, DR, DI, Z, LDZ, SIGMAR, SIGMAI, WORKEV, BMAT, -c N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, WORKD, WORKL, -c LWORKL, INFO ) -c -c\Arguments: -c RVEC LOGICAL (INPUT) -c Specifies whether a basis for the invariant subspace corresponding -c to the converged Ritz value approximations for the eigenproblem -c A*z = lambda*B*z is computed. -c -c RVEC = .FALSE. Compute Ritz values only. -c -c RVEC = .TRUE. Compute the Ritz vectors or Schur vectors. -c See Remarks below. -c -c HOWMNY Character*1 (INPUT) -c Specifies the form of the basis for the invariant subspace -c corresponding to the converged Ritz values that is to be computed. -c -c = 'A': Compute NEV Ritz vectors; -c = 'P': Compute NEV Schur vectors; -c = 'S': compute some of the Ritz vectors, specified -c by the logical array SELECT. -c -c SELECT Logical array of dimension NCV. (INPUT) -c If HOWMNY = 'S', SELECT specifies the Ritz vectors to be -c computed. To select the Ritz vector corresponding to a -c Ritz value (DR(j), DI(j)), SELECT(j) must be set to .TRUE.. -c If HOWMNY = 'A' or 'P', SELECT is used as internal workspace. -c -c DR Double precision array of dimension NEV+1. (OUTPUT) -c If IPARAM(7) = 1,2 or 3 and SIGMAI=0.0 then on exit: DR contains -c the real part of the Ritz approximations to the eigenvalues of -c A*z = lambda*B*z. -c If IPARAM(7) = 3, 4 and SIGMAI is not equal to zero, then on exit: -c DR contains the real part of the Ritz values of OP computed by -c DNAUPD . A further computation must be performed by the user -c to transform the Ritz values computed for OP by DNAUPD to those -c of the original system A*z = lambda*B*z. See remark 3 below. -c -c DI Double precision array of dimension NEV+1. (OUTPUT) -c On exit, DI contains the imaginary part of the Ritz value -c approximations to the eigenvalues of A*z = lambda*B*z associated -c with DR. -c -c NOTE: When Ritz values are complex, they will come in complex -c conjugate pairs. If eigenvectors are requested, the -c corresponding Ritz vectors will also come in conjugate -c pairs and the real and imaginary parts of these are -c represented in two consecutive columns of the array Z -c (see below). -c -c Z Double precision N by NEV+1 array if RVEC = .TRUE. and HOWMNY = 'A'. (OUTPUT) -c On exit, if RVEC = .TRUE. and HOWMNY = 'A', then the columns of -c Z represent approximate eigenvectors (Ritz vectors) corresponding -c to the NCONV=IPARAM(5) Ritz values for eigensystem -c A*z = lambda*B*z. -c -c The complex Ritz vector associated with the Ritz value -c with positive imaginary part is stored in two consecutive -c columns. The first column holds the real part of the Ritz -c vector and the second column holds the imaginary part. The -c Ritz vector associated with the Ritz value with negative -c imaginary part is simply the complex conjugate of the Ritz vector -c associated with the positive imaginary part. -c -c If RVEC = .FALSE. or HOWMNY = 'P', then Z is not referenced. -c -c NOTE: If if RVEC = .TRUE. and a Schur basis is not required, -c the array Z may be set equal to first NEV+1 columns of the Arnoldi -c basis array V computed by DNAUPD . In this case the Arnoldi basis -c will be destroyed and overwritten with the eigenvector basis. -c -c LDZ Integer. (INPUT) -c The leading dimension of the array Z. If Ritz vectors are -c desired, then LDZ >= max( 1, N ). In any case, LDZ >= 1. -c -c SIGMAR Double precision (INPUT) -c If IPARAM(7) = 3 or 4, represents the real part of the shift. -c Not referenced if IPARAM(7) = 1 or 2. -c -c SIGMAI Double precision (INPUT) -c If IPARAM(7) = 3 or 4, represents the imaginary part of the shift. -c Not referenced if IPARAM(7) = 1 or 2. See remark 3 below. -c -c WORKEV Double precision work array of dimension 3*NCV. (WORKSPACE) -c -c **** The remaining arguments MUST be the same as for the **** -c **** call to DNAUPD that was just completed. **** -c -c NOTE: The remaining arguments -c -c BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, -c WORKD, WORKL, LWORKL, INFO -c -c must be passed directly to DNEUPD following the last call -c to DNAUPD . These arguments MUST NOT BE MODIFIED between -c the the last call to DNAUPD and the call to DNEUPD . -c -c Three of these parameters (V, WORKL, INFO) are also output parameters: -c -c V Double precision N by NCV array. (INPUT/OUTPUT) -c -c Upon INPUT: the NCV columns of V contain the Arnoldi basis -c vectors for OP as constructed by DNAUPD . -c -c Upon OUTPUT: If RVEC = .TRUE. the first NCONV=IPARAM(5) columns -c contain approximate Schur vectors that span the -c desired invariant subspace. See Remark 2 below. -c -c NOTE: If the array Z has been set equal to first NEV+1 columns -c of the array V and RVEC=.TRUE. and HOWMNY= 'A', then the -c Arnoldi basis held by V has been overwritten by the desired -c Ritz vectors. If a separate array Z has been passed then -c the first NCONV=IPARAM(5) columns of V will contain approximate -c Schur vectors that span the desired invariant subspace. -c -c WORKL Double precision work array of length LWORKL. (OUTPUT/WORKSPACE) -c WORKL(1:ncv*ncv+3*ncv) contains information obtained in -c dnaupd . They are not changed by dneupd . -c WORKL(ncv*ncv+3*ncv+1:3*ncv*ncv+6*ncv) holds the -c real and imaginary part of the untransformed Ritz values, -c the upper quasi-triangular matrix for H, and the -c associated matrix representation of the invariant subspace for H. -c -c Note: IPNTR(9:13) contains the pointer into WORKL for addresses -c of the above information computed by dneupd . -c ------------------------------------------------------------- -c IPNTR(9): pointer to the real part of the NCV RITZ values of the -c original system. -c IPNTR(10): pointer to the imaginary part of the NCV RITZ values of -c the original system. -c IPNTR(11): pointer to the NCV corresponding error bounds. -c IPNTR(12): pointer to the NCV by NCV upper quasi-triangular -c Schur matrix for H. -c IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors -c of the upper Hessenberg matrix H. Only referenced by -c dneupd if RVEC = .TRUE. See Remark 2 below. -c ------------------------------------------------------------- -c -c INFO Integer. (OUTPUT) -c Error flag on output. -c -c = 0: Normal exit. -c -c = 1: The Schur form computed by LAPACK routine dlahqr -c could not be reordered by LAPACK routine dtrsen . -c Re-enter subroutine dneupd with IPARAM(5)=NCV and -c increase the size of the arrays DR and DI to have -c dimension at least dimension NCV and allocate at least NCV -c columns for Z. NOTE: Not necessary if Z and V share -c the same space. Please notify the authors if this error -c occurs. -c -c = -1: N must be positive. -c = -2: NEV must be positive. -c = -3: NCV-NEV >= 2 and less than or equal to N. -c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI' -c = -6: BMAT must be one of 'I' or 'G'. -c = -7: Length of private work WORKL array is not sufficient. -c = -8: Error return from calculation of a real Schur form. -c Informational error from LAPACK routine dlahqr . -c = -9: Error return from calculation of eigenvectors. -c Informational error from LAPACK routine dtrevc . -c = -10: IPARAM(7) must be 1,2,3,4. -c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. -c = -12: HOWMNY = 'S' not yet implemented -c = -13: HOWMNY must be one of 'A' or 'P' if RVEC = .true. -c = -14: DNAUPD did not find any eigenvalues to sufficient -c accuracy. -c = -15: DNEUPD got a different count of the number of converged -c Ritz values than DNAUPD got. This indicates the user -c probably made an error in passing data from DNAUPD to -c DNEUPD or that the data was modified before entering -c DNEUPD -c -c\BeginLib -c -c\References: -c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in -c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), -c pp 357-385. -c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly -c Restarted Arnoldi Iteration", Rice University Technical Report -c TR95-13, Department of Computational and Applied Mathematics. -c 3. B.N. Parlett & Y. Saad, "Complex Shift and Invert Strategies for -c Real Matrices", Linear Algebra and its Applications, vol 88/89, -c pp 575-595, (1987). -c -c\Routines called: -c ivout ARPACK utility routine that prints integers. -c dmout ARPACK utility routine that prints matrices -c dvout ARPACK utility routine that prints vectors. -c dgeqr2 LAPACK routine that computes the QR factorization of -c a matrix. -c dlacpy LAPACK matrix copy routine. -c dlahqr LAPACK routine to compute the real Schur form of an -c upper Hessenberg matrix. -c dlamch LAPACK routine that determines machine constants. -c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. -c dlaset LAPACK matrix initialization routine. -c dorm2r LAPACK routine that applies an orthogonal matrix in -c factored form. -c dtrevc LAPACK routine to compute the eigenvectors of a matrix -c in upper quasi-triangular form. -c dtrsen LAPACK routine that re-orders the Schur form. -c dtrmm Level 3 BLAS matrix times an upper triangular matrix. -c dger Level 2 BLAS rank one update to a matrix. -c dcopy Level 1 BLAS that copies one vector to another . -c ddot Level 1 BLAS that computes the scalar product of two vectors. -c dnrm2 Level 1 BLAS that computes the norm of a vector. -c dscal Level 1 BLAS that scales a vector. -c -c\Remarks -c -c 1. Currently only HOWMNY = 'A' and 'P' are implemented. -c -c Let trans(X) denote the transpose of X. -c -c 2. Schur vectors are an orthogonal representation for the basis of -c Ritz vectors. Thus, their numerical properties are often superior. -c If RVEC = .TRUE. then the relationship -c A * V(:,1:IPARAM(5)) = V(:,1:IPARAM(5)) * T, and -c trans(V(:,1:IPARAM(5))) * V(:,1:IPARAM(5)) = I are approximately -c satisfied. Here T is the leading submatrix of order IPARAM(5) of the -c real upper quasi-triangular matrix stored workl(ipntr(12)). That is, -c T is block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; -c each 2-by-2 diagonal block has its diagonal elements equal and its -c off-diagonal elements of opposite sign. Corresponding to each 2-by-2 -c diagonal block is a complex conjugate pair of Ritz values. The real -c Ritz values are stored on the diagonal of T. -c -c 3. If IPARAM(7) = 3 or 4 and SIGMAI is not equal zero, then the user must -c form the IPARAM(5) Rayleigh quotients in order to transform the Ritz -c values computed by DNAUPD for OP to those of A*z = lambda*B*z. -c Set RVEC = .true. and HOWMNY = 'A', and -c compute -c trans(Z(:,I)) * A * Z(:,I) if DI(I) = 0. -c If DI(I) is not equal to zero and DI(I+1) = - D(I), -c then the desired real and imaginary parts of the Ritz value are -c trans(Z(:,I)) * A * Z(:,I) + trans(Z(:,I+1)) * A * Z(:,I+1), -c trans(Z(:,I)) * A * Z(:,I+1) - trans(Z(:,I+1)) * A * Z(:,I), -c respectively. -c Another possibility is to set RVEC = .true. and HOWMNY = 'P' and -c compute trans(V(:,1:IPARAM(5))) * A * V(:,1:IPARAM(5)) and then an upper -c quasi-triangular matrix of order IPARAM(5) is computed. See remark -c 2 above. -c -c\Authors -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Chao Yang Houston, Texas -c Dept. of Computational & -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\SCCS Information: @(#) -c FILE: neupd.F SID: 2.7 DATE OF SID: 09/20/00 RELEASE: 2 -c -c\EndLib -c -c----------------------------------------------------------------------- - subroutine dneupd (rvec , howmny, select, dr , di, - & z , ldz , sigmar, sigmai, workev, - & bmat , n , which , nev , tol, - & resid, ncv , v , ldv , iparam, - & ipntr, workd , workl , lworkl, info) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - character bmat, howmny, which*2 - logical rvec - integer info, ldz, ldv, lworkl, n, ncv, nev - Double precision - & sigmar, sigmai, tol -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - integer iparam(11), ipntr(14) - logical select(ncv) - Double precision - & dr(nev+1) , di(nev+1), resid(n) , - & v(ldv,ncv) , z(ldz,*) , workd(3*n), - & workl(lworkl), workev(3*ncv) -c -c %------------% -c | Parameters | -c %------------% -c - Double precision - & one, zero - parameter (one = 1.0D+0 , zero = 0.0D+0 ) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - character type*6 - integer bounds, ierr , ih , ihbds , - & iheigr, iheigi, iconj , nconv , - & invsub, iuptri, iwev , iwork(1), - & j , k , ldh , ldq , - & mode , msglvl, outncv, ritzr , - & ritzi , wri , wrr , irr , - & iri , ibd , ishift, numcnv , - & np , jj , nconv2 - logical reord - Double precision - & conds , rnorm, sep , temp, - & vl(1,1), temp1, eps23 -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external dcopy , dger , dgeqr2 , dlacpy , - & dlahqr , dlaset , dmout , dorm2r , - & dtrevc , dtrmm , dtrsen , dscal , - & dvout , ivout -c -c %--------------------% -c | External Functions | -c %--------------------% -c - Double precision - & dlapy2 , dnrm2 , dlamch , ddot - external dlapy2 , dnrm2 , dlamch , ddot -c -c %---------------------% -c | Intrinsic Functions | -c %---------------------% -c - intrinsic abs, min, sqrt -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c -c %------------------------% -c | Set default parameters | -c %------------------------% -c - msglvl = mneupd - mode = iparam(7) - nconv = iparam(5) - info = 0 -c -c %---------------------------------% -c | Get machine dependent constant. | -c %---------------------------------% -c - eps23 = dlamch ('Epsilon-Machine') - eps23 = eps23**(2.0D+0 / 3.0D+0 ) -c -c %--------------% -c | Quick return | -c %--------------% -c - ierr = 0 -c - if (nconv .le. 0) then - ierr = -14 - else if (n .le. 0) then - ierr = -1 - else if (nev .le. 0) then - ierr = -2 - else if (ncv .le. nev+1 .or. ncv .gt. n) then - ierr = -3 - else if (which .ne. 'LM' .and. - & which .ne. 'SM' .and. - & which .ne. 'LR' .and. - & which .ne. 'SR' .and. - & which .ne. 'LI' .and. - & which .ne. 'SI') then - ierr = -5 - else if (bmat .ne. 'I' .and. bmat .ne. 'G') then - ierr = -6 - else if (lworkl .lt. 3*ncv**2 + 6*ncv) then - ierr = -7 - else if ( (howmny .ne. 'A' .and. - & howmny .ne. 'P' .and. - & howmny .ne. 'S') .and. rvec ) then - ierr = -13 - else if (howmny .eq. 'S' ) then - ierr = -12 - end if -c - if (mode .eq. 1 .or. mode .eq. 2) then - type = 'REGULR' - else if (mode .eq. 3 .and. sigmai .eq. zero) then - type = 'SHIFTI' - else if (mode .eq. 3 ) then - type = 'REALPT' - else if (mode .eq. 4 ) then - type = 'IMAGPT' - else - ierr = -10 - end if - if (mode .eq. 1 .and. bmat .eq. 'G') ierr = -11 -c -c %------------% -c | Error Exit | -c %------------% -c - if (ierr .ne. 0) then - info = ierr - go to 9000 - end if -c -c %--------------------------------------------------------% -c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | -c | etc... and the remaining workspace. | -c | Also update pointer to be used on output. | -c | Memory is laid out as follows: | -c | workl(1:ncv*ncv) := generated Hessenberg matrix | -c | workl(ncv*ncv+1:ncv*ncv+2*ncv) := real and imaginary | -c | parts of ritz values | -c | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := error bounds | -c %--------------------------------------------------------% -c -c %-----------------------------------------------------------% -c | The following is used and set by DNEUPD . | -c | workl(ncv*ncv+3*ncv+1:ncv*ncv+4*ncv) := The untransformed | -c | real part of the Ritz values. | -c | workl(ncv*ncv+4*ncv+1:ncv*ncv+5*ncv) := The untransformed | -c | imaginary part of the Ritz values. | -c | workl(ncv*ncv+5*ncv+1:ncv*ncv+6*ncv) := The untransformed | -c | error bounds of the Ritz values | -c | workl(ncv*ncv+6*ncv+1:2*ncv*ncv+6*ncv) := Holds the upper | -c | quasi-triangular matrix for H | -c | workl(2*ncv*ncv+6*ncv+1: 3*ncv*ncv+6*ncv) := Holds the | -c | associated matrix representation of the invariant | -c | subspace for H. | -c | GRAND total of NCV * ( 3 * NCV + 6 ) locations. | -c %-----------------------------------------------------------% -c - ih = ipntr(5) - ritzr = ipntr(6) - ritzi = ipntr(7) - bounds = ipntr(8) - ldh = ncv - ldq = ncv - iheigr = bounds + ldh - iheigi = iheigr + ldh - ihbds = iheigi + ldh - iuptri = ihbds + ldh - invsub = iuptri + ldh*ncv - ipntr(9) = iheigr - ipntr(10) = iheigi - ipntr(11) = ihbds - ipntr(12) = iuptri - ipntr(13) = invsub - wrr = 1 - wri = ncv + 1 - iwev = wri + ncv -c -c %-----------------------------------------% -c | irr points to the REAL part of the Ritz | -c | values computed by _neigh before | -c | exiting _naup2. | -c | iri points to the IMAGINARY part of the | -c | Ritz values computed by _neigh | -c | before exiting _naup2. | -c | ibd points to the Ritz estimates | -c | computed by _neigh before exiting | -c | _naup2. | -c %-----------------------------------------% -c - irr = ipntr(14)+ncv*ncv - iri = irr+ncv - ibd = iri+ncv -c -c %------------------------------------% -c | RNORM is B-norm of the RESID(1:N). | -c %------------------------------------% -c - rnorm = workl(ih+2) - workl(ih+2) = zero -c - if (msglvl .gt. 2) then - call dvout (logfil, ncv, workl(irr), ndigit, - & '_neupd: Real part of Ritz values passed in from _NAUPD.') - call dvout (logfil, ncv, workl(iri), ndigit, - & '_neupd: Imag part of Ritz values passed in from _NAUPD.') - call dvout (logfil, ncv, workl(ibd), ndigit, - & '_neupd: Ritz estimates passed in from _NAUPD.') - end if -c - if (rvec) then -c - reord = .false. -c -c %---------------------------------------------------% -c | Use the temporary bounds array to store indices | -c | These will be used to mark the select array later | -c %---------------------------------------------------% -c - do 10 j = 1,ncv - workl(bounds+j-1) = j - select(j) = .false. - 10 continue -c -c %-------------------------------------% -c | Select the wanted Ritz values. | -c | Sort the Ritz values so that the | -c | wanted ones appear at the tailing | -c | NEV positions of workl(irr) and | -c | workl(iri). Move the corresponding | -c | error estimates in workl(bound) | -c | accordingly. | -c %-------------------------------------% -c - np = ncv - nev - ishift = 0 - call dngets (ishift , which , nev , - & np , workl(irr), workl(iri), - & workl(bounds), workl , workl(np+1)) -c - if (msglvl .gt. 2) then - call dvout (logfil, ncv, workl(irr), ndigit, - & '_neupd: Real part of Ritz values after calling _NGETS.') - call dvout (logfil, ncv, workl(iri), ndigit, - & '_neupd: Imag part of Ritz values after calling _NGETS.') - call dvout (logfil, ncv, workl(bounds), ndigit, - & '_neupd: Ritz value indices after calling _NGETS.') - end if -c -c %-----------------------------------------------------% -c | Record indices of the converged wanted Ritz values | -c | Mark the select array for possible reordering | -c %-----------------------------------------------------% -c - numcnv = 0 - do 11 j = 1,ncv - temp1 = max(eps23, - & dlapy2 ( workl(irr+ncv-j), workl(iri+ncv-j) )) - jj = workl(bounds + ncv - j) - if (numcnv .lt. nconv .and. - & workl(ibd+jj-1) .le. tol*temp1) then - select(jj) = .true. - numcnv = numcnv + 1 - if (jj .gt. nev) reord = .true. - endif - 11 continue -c -c %-----------------------------------------------------------% -c | Check the count (numcnv) of converged Ritz values with | -c | the number (nconv) reported by dnaupd. If these two | -c | are different then there has probably been an error | -c | caused by incorrect passing of the dnaupd data. | -c %-----------------------------------------------------------% -c - if (msglvl .gt. 2) then - call ivout(logfil, 1, numcnv, ndigit, - & '_neupd: Number of specified eigenvalues') - call ivout(logfil, 1, nconv, ndigit, - & '_neupd: Number of "converged" eigenvalues') - end if -c - if (numcnv .ne. nconv) then - info = -15 - go to 9000 - end if -c -c %-----------------------------------------------------------% -c | Call LAPACK routine dlahqr to compute the real Schur form | -c | of the upper Hessenberg matrix returned by DNAUPD . | -c | Make a copy of the upper Hessenberg matrix. | -c | Initialize the Schur vector matrix Q to the identity. | -c %-----------------------------------------------------------% -c - call dcopy (ldh*ncv, workl(ih), 1, workl(iuptri), 1) - call dlaset ('All', ncv, ncv, - & zero , one, workl(invsub), - & ldq) - call dlahqr (.true., .true. , ncv, - & 1 , ncv , workl(iuptri), - & ldh , workl(iheigr), workl(iheigi), - & 1 , ncv , workl(invsub), - & ldq , ierr) - call dcopy (ncv , workl(invsub+ncv-1), ldq, - & workl(ihbds), 1) -c - if (ierr .ne. 0) then - info = -8 - go to 9000 - end if -c - if (msglvl .gt. 1) then - call dvout (logfil, ncv, workl(iheigr), ndigit, - & '_neupd: Real part of the eigenvalues of H') - call dvout (logfil, ncv, workl(iheigi), ndigit, - & '_neupd: Imaginary part of the Eigenvalues of H') - call dvout (logfil, ncv, workl(ihbds), ndigit, - & '_neupd: Last row of the Schur vector matrix') - if (msglvl .gt. 3) then - call dmout (logfil , ncv, ncv , - & workl(iuptri), ldh, ndigit, - & '_neupd: The upper quasi-triangular matrix ') - end if - end if -c - if (reord) then -c -c %-----------------------------------------------------% -c | Reorder the computed upper quasi-triangular matrix. | -c %-----------------------------------------------------% -c - call dtrsen ('None' , 'V' , - & select , ncv , - & workl(iuptri), ldh , - & workl(invsub), ldq , - & workl(iheigr), workl(iheigi), - & nconv2 , conds , - & sep , workl(ihbds) , - & ncv , iwork , - & 1 , ierr) -c - if (nconv2 .lt. nconv) then - nconv = nconv2 - end if - - if (ierr .eq. 1) then - info = 1 - go to 9000 - end if -c - - if (msglvl .gt. 2) then - call dvout (logfil, ncv, workl(iheigr), ndigit, - & '_neupd: Real part of the eigenvalues of H--reordered') - call dvout (logfil, ncv, workl(iheigi), ndigit, - & '_neupd: Imag part of the eigenvalues of H--reordered') - if (msglvl .gt. 3) then - call dmout (logfil , ncv, ncv , - & workl(iuptri), ldq, ndigit, - & '_neupd: Quasi-triangular matrix after re-ordering') - end if - end if -c - end if -c -c %---------------------------------------% -c | Copy the last row of the Schur vector | -c | into workl(ihbds). This will be used | -c | to compute the Ritz estimates of | -c | converged Ritz values. | -c %---------------------------------------% -c - call dcopy (ncv, workl(invsub+ncv-1), ldq, workl(ihbds), 1) -c -c %----------------------------------------------------% -c | Place the computed eigenvalues of H into DR and DI | -c | if a spectral transformation was not used. | -c %----------------------------------------------------% -c - if (type .eq. 'REGULR') then - call dcopy (nconv, workl(iheigr), 1, dr, 1) - call dcopy (nconv, workl(iheigi), 1, di, 1) - end if -c -c %----------------------------------------------------------% -c | Compute the QR factorization of the matrix representing | -c | the wanted invariant subspace located in the first NCONV | -c | columns of workl(invsub,ldq). | -c %----------------------------------------------------------% -c - call dgeqr2 (ncv, nconv , workl(invsub), - & ldq, workev, workev(ncv+1), - & ierr) -c -c %---------------------------------------------------------% -c | * Postmultiply V by Q using dorm2r . | -c | * Copy the first NCONV columns of VQ into Z. | -c | * Postmultiply Z by R. | -c | The N by NCONV matrix Z is now a matrix representation | -c | of the approximate invariant subspace associated with | -c | the Ritz values in workl(iheigr) and workl(iheigi) | -c | The first NCONV columns of V are now approximate Schur | -c | vectors associated with the real upper quasi-triangular | -c | matrix of order NCONV in workl(iuptri) | -c %---------------------------------------------------------% -c - call dorm2r ('Right', 'Notranspose', n , - & ncv , nconv , workl(invsub), - & ldq , workev , v , - & ldv , workd(n+1) , ierr) - call dlacpy ('All', n, nconv, v, ldv, z, ldz) -c - do 20 j=1, nconv -c -c %---------------------------------------------------% -c | Perform both a column and row scaling if the | -c | diagonal element of workl(invsub,ldq) is negative | -c | I'm lazy and don't take advantage of the upper | -c | quasi-triangular form of workl(iuptri,ldq) | -c | Note that since Q is orthogonal, R is a diagonal | -c | matrix consisting of plus or minus ones | -c %---------------------------------------------------% -c - if (workl(invsub+(j-1)*ldq+j-1) .lt. zero) then - call dscal (nconv, -one, workl(iuptri+j-1), ldq) - call dscal (nconv, -one, workl(iuptri+(j-1)*ldq), 1) - end if -c - 20 continue -c - if (howmny .eq. 'A') then -c -c %--------------------------------------------% -c | Compute the NCONV wanted eigenvectors of T | -c | located in workl(iuptri,ldq). | -c %--------------------------------------------% -c - do 30 j=1, ncv - if (j .le. nconv) then - select(j) = .true. - else - select(j) = .false. - end if - 30 continue -c - call dtrevc ('Right', 'Select' , select , - & ncv , workl(iuptri), ldq , - & vl , 1 , workl(invsub), - & ldq , ncv , outncv , - & workev , ierr) -c - if (ierr .ne. 0) then - info = -9 - go to 9000 - end if -c -c %------------------------------------------------% -c | Scale the returning eigenvectors so that their | -c | Euclidean norms are all one. LAPACK subroutine | -c | dtrevc returns each eigenvector normalized so | -c | that the element of largest magnitude has | -c | magnitude 1; | -c %------------------------------------------------% -c - iconj = 0 - do 40 j=1, nconv -c - if ( workl(iheigi+j-1) .eq. zero ) then -c -c %----------------------% -c | real eigenvalue case | -c %----------------------% -c - temp = dnrm2 ( ncv, workl(invsub+(j-1)*ldq), 1 ) - call dscal ( ncv, one / temp, - & workl(invsub+(j-1)*ldq), 1 ) -c - else -c -c %-------------------------------------------% -c | Complex conjugate pair case. Note that | -c | since the real and imaginary part of | -c | the eigenvector are stored in consecutive | -c | columns, we further normalize by the | -c | square root of two. | -c %-------------------------------------------% -c - if (iconj .eq. 0) then - temp = dlapy2 (dnrm2 (ncv, - & workl(invsub+(j-1)*ldq), - & 1), - & dnrm2 (ncv, - & workl(invsub+j*ldq), - & 1)) - call dscal (ncv, one/temp, - & workl(invsub+(j-1)*ldq), 1 ) - call dscal (ncv, one/temp, - & workl(invsub+j*ldq), 1 ) - iconj = 1 - else - iconj = 0 - end if -c - end if -c - 40 continue -c - call dgemv ('T', ncv, nconv, one, workl(invsub), - & ldq, workl(ihbds), 1, zero, workev, 1) -c - iconj = 0 - do 45 j=1, nconv - if (workl(iheigi+j-1) .ne. zero) then -c -c %-------------------------------------------% -c | Complex conjugate pair case. Note that | -c | since the real and imaginary part of | -c | the eigenvector are stored in consecutive | -c %-------------------------------------------% -c - if (iconj .eq. 0) then - workev(j) = dlapy2 (workev(j), workev(j+1)) - workev(j+1) = workev(j) - iconj = 1 - else - iconj = 0 - end if - end if - 45 continue -c - if (msglvl .gt. 2) then - call dcopy (ncv, workl(invsub+ncv-1), ldq, - & workl(ihbds), 1) - call dvout (logfil, ncv, workl(ihbds), ndigit, - & '_neupd: Last row of the eigenvector matrix for T') - if (msglvl .gt. 3) then - call dmout (logfil, ncv, ncv, workl(invsub), ldq, - & ndigit, '_neupd: The eigenvector matrix for T') - end if - end if -c -c %---------------------------------------% -c | Copy Ritz estimates into workl(ihbds) | -c %---------------------------------------% -c - call dcopy (nconv, workev, 1, workl(ihbds), 1) -c -c %---------------------------------------------------------% -c | Compute the QR factorization of the eigenvector matrix | -c | associated with leading portion of T in the first NCONV | -c | columns of workl(invsub,ldq). | -c %---------------------------------------------------------% -c - call dgeqr2 (ncv, nconv , workl(invsub), - & ldq, workev, workev(ncv+1), - & ierr) -c -c %----------------------------------------------% -c | * Postmultiply Z by Q. | -c | * Postmultiply Z by R. | -c | The N by NCONV matrix Z is now contains the | -c | Ritz vectors associated with the Ritz values | -c | in workl(iheigr) and workl(iheigi). | -c %----------------------------------------------% -c - call dorm2r ('Right', 'Notranspose', n , - & ncv , nconv , workl(invsub), - & ldq , workev , z , - & ldz , workd(n+1) , ierr) -c - call dtrmm ('Right' , 'Upper' , 'No transpose', - & 'Non-unit', n , nconv , - & one , workl(invsub), ldq , - & z , ldz) -c - end if -c - else -c -c %------------------------------------------------------% -c | An approximate invariant subspace is not needed. | -c | Place the Ritz values computed DNAUPD into DR and DI | -c %------------------------------------------------------% -c - call dcopy (nconv, workl(ritzr), 1, dr, 1) - call dcopy (nconv, workl(ritzi), 1, di, 1) - call dcopy (nconv, workl(ritzr), 1, workl(iheigr), 1) - call dcopy (nconv, workl(ritzi), 1, workl(iheigi), 1) - call dcopy (nconv, workl(bounds), 1, workl(ihbds), 1) - end if -c -c %------------------------------------------------% -c | Transform the Ritz values and possibly vectors | -c | and corresponding error bounds of OP to those | -c | of A*x = lambda*B*x. | -c %------------------------------------------------% -c - if (type .eq. 'REGULR') then -c - if (rvec) - & call dscal (ncv, rnorm, workl(ihbds), 1) -c - else -c -c %---------------------------------------% -c | A spectral transformation was used. | -c | * Determine the Ritz estimates of the | -c | Ritz values in the original system. | -c %---------------------------------------% -c - if (type .eq. 'SHIFTI') then -c - if (rvec) - & call dscal (ncv, rnorm, workl(ihbds), 1) -c - do 50 k=1, ncv - temp = dlapy2 ( workl(iheigr+k-1), - & workl(iheigi+k-1) ) - workl(ihbds+k-1) = abs( workl(ihbds+k-1) ) - & / temp / temp - 50 continue -c - else if (type .eq. 'REALPT') then -c - do 60 k=1, ncv - 60 continue -c - else if (type .eq. 'IMAGPT') then -c - do 70 k=1, ncv - 70 continue -c - end if -c -c %-----------------------------------------------------------% -c | * Transform the Ritz values back to the original system. | -c | For TYPE = 'SHIFTI' the transformation is | -c | lambda = 1/theta + sigma | -c | For TYPE = 'REALPT' or 'IMAGPT' the user must from | -c | Rayleigh quotients or a projection. See remark 3 above.| -c | NOTES: | -c | *The Ritz vectors are not affected by the transformation. | -c %-----------------------------------------------------------% -c - if (type .eq. 'SHIFTI') then -c - do 80 k=1, ncv - temp = dlapy2 ( workl(iheigr+k-1), - & workl(iheigi+k-1) ) - workl(iheigr+k-1) = workl(iheigr+k-1)/temp/temp - & + sigmar - workl(iheigi+k-1) = -workl(iheigi+k-1)/temp/temp - & + sigmai - 80 continue -c - call dcopy (nconv, workl(iheigr), 1, dr, 1) - call dcopy (nconv, workl(iheigi), 1, di, 1) -c - else if (type .eq. 'REALPT' .or. type .eq. 'IMAGPT') then -c - call dcopy (nconv, workl(iheigr), 1, dr, 1) - call dcopy (nconv, workl(iheigi), 1, di, 1) -c - end if -c - end if -c - if (type .eq. 'SHIFTI' .and. msglvl .gt. 1) then - call dvout (logfil, nconv, dr, ndigit, - & '_neupd: Untransformed real part of the Ritz valuess.') - call dvout (logfil, nconv, di, ndigit, - & '_neupd: Untransformed imag part of the Ritz valuess.') - call dvout (logfil, nconv, workl(ihbds), ndigit, - & '_neupd: Ritz estimates of untransformed Ritz values.') - else if (type .eq. 'REGULR' .and. msglvl .gt. 1) then - call dvout (logfil, nconv, dr, ndigit, - & '_neupd: Real parts of converged Ritz values.') - call dvout (logfil, nconv, di, ndigit, - & '_neupd: Imag parts of converged Ritz values.') - call dvout (logfil, nconv, workl(ihbds), ndigit, - & '_neupd: Associated Ritz estimates.') - end if -c -c %-------------------------------------------------% -c | Eigenvector Purification step. Formally perform | -c | one of inverse subspace iteration. Only used | -c | for MODE = 2. | -c %-------------------------------------------------% -c - if (rvec .and. howmny .eq. 'A' .and. type .eq. 'SHIFTI') then -c -c %------------------------------------------------% -c | Purify the computed Ritz vectors by adding a | -c | little bit of the residual vector: | -c | T | -c | resid(:)*( e s ) / theta | -c | NCV | -c | where H s = s theta. Remember that when theta | -c | has nonzero imaginary part, the corresponding | -c | Ritz vector is stored across two columns of Z. | -c %------------------------------------------------% -c - iconj = 0 - do 110 j=1, nconv - if (workl(iheigi+j-1) .eq. zero) then - workev(j) = workl(invsub+(j-1)*ldq+ncv-1) / - & workl(iheigr+j-1) - else if (iconj .eq. 0) then - temp = dlapy2 ( workl(iheigr+j-1), workl(iheigi+j-1) ) - workev(j) = ( workl(invsub+(j-1)*ldq+ncv-1) * - & workl(iheigr+j-1) + - & workl(invsub+j*ldq+ncv-1) * - & workl(iheigi+j-1) ) / temp / temp - workev(j+1) = ( workl(invsub+j*ldq+ncv-1) * - & workl(iheigr+j-1) - - & workl(invsub+(j-1)*ldq+ncv-1) * - & workl(iheigi+j-1) ) / temp / temp - iconj = 1 - else - iconj = 0 - end if - 110 continue -c -c %---------------------------------------% -c | Perform a rank one update to Z and | -c | purify all the Ritz vectors together. | -c %---------------------------------------% -c - call dger (n, nconv, one, resid, 1, workev, 1, z, ldz) -c - end if -c - 9000 continue -c - return -c -c %---------------% -c | End of DNEUPD | -c %---------------% -c - end
--- a/libcruft/arpack/src/dngets.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,231 +0,0 @@ -c----------------------------------------------------------------------- -c\BeginDoc -c -c\Name: dngets -c -c\Description: -c Given the eigenvalues of the upper Hessenberg matrix H, -c computes the NP shifts AMU that are zeros of the polynomial of -c degree NP which filters out components of the unwanted eigenvectors -c corresponding to the AMU's based on some given criteria. -c -c NOTE: call this even in the case of user specified shifts in order -c to sort the eigenvalues, and error bounds of H for later use. -c -c\Usage: -c call dngets -c ( ISHIFT, WHICH, KEV, NP, RITZR, RITZI, BOUNDS, SHIFTR, SHIFTI ) -c -c\Arguments -c ISHIFT Integer. (INPUT) -c Method for selecting the implicit shifts at each iteration. -c ISHIFT = 0: user specified shifts -c ISHIFT = 1: exact shift with respect to the matrix H. -c -c WHICH Character*2. (INPUT) -c Shift selection criteria. -c 'LM' -> want the KEV eigenvalues of largest magnitude. -c 'SM' -> want the KEV eigenvalues of smallest magnitude. -c 'LR' -> want the KEV eigenvalues of largest real part. -c 'SR' -> want the KEV eigenvalues of smallest real part. -c 'LI' -> want the KEV eigenvalues of largest imaginary part. -c 'SI' -> want the KEV eigenvalues of smallest imaginary part. -c -c KEV Integer. (INPUT/OUTPUT) -c INPUT: KEV+NP is the size of the matrix H. -c OUTPUT: Possibly increases KEV by one to keep complex conjugate -c pairs together. -c -c NP Integer. (INPUT/OUTPUT) -c Number of implicit shifts to be computed. -c OUTPUT: Possibly decreases NP by one to keep complex conjugate -c pairs together. -c -c RITZR, Double precision array of length KEV+NP. (INPUT/OUTPUT) -c RITZI On INPUT, RITZR and RITZI contain the real and imaginary -c parts of the eigenvalues of H. -c On OUTPUT, RITZR and RITZI are sorted so that the unwanted -c eigenvalues are in the first NP locations and the wanted -c portion is in the last KEV locations. When exact shifts are -c selected, the unwanted part corresponds to the shifts to -c be applied. Also, if ISHIFT .eq. 1, the unwanted eigenvalues -c are further sorted so that the ones with largest Ritz values -c are first. -c -c BOUNDS Double precision array of length KEV+NP. (INPUT/OUTPUT) -c Error bounds corresponding to the ordering in RITZ. -c -c SHIFTR, SHIFTI *** USE deprecated as of version 2.1. *** -c -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Local variables: -c xxxxxx real -c -c\Routines called: -c dsortc ARPACK sorting routine. -c dcopy Level 1 BLAS that copies one vector to another . -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\Revision history: -c xx/xx/92: Version ' 2.1' -c -c\SCCS Information: @(#) -c FILE: ngets.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2 -c -c\Remarks -c 1. xxxx -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine dngets ( ishift, which, kev, np, ritzr, ritzi, bounds, - & shiftr, shifti ) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - character*2 which - integer ishift, kev, np -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - Double precision - & bounds(kev+np), ritzr(kev+np), ritzi(kev+np), - & shiftr(1), shifti(1) -c -c %------------% -c | Parameters | -c %------------% -c - Double precision - & one, zero - parameter (one = 1.0, zero = 0.0) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - integer msglvl -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external dcopy, dsortc, arscnd -c -c %----------------------% -c | Intrinsics Functions | -c %----------------------% -c - intrinsic abs -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c -c %-------------------------------% -c | Initialize timing statistics | -c | & message level for debugging | -c %-------------------------------% -c - call arscnd (t0) - msglvl = mngets -c -c %----------------------------------------------------% -c | LM, SM, LR, SR, LI, SI case. | -c | Sort the eigenvalues of H into the desired order | -c | and apply the resulting order to BOUNDS. | -c | The eigenvalues are sorted so that the wanted part | -c | are always in the last KEV locations. | -c | We first do a pre-processing sort in order to keep | -c | complex conjugate pairs together | -c %----------------------------------------------------% -c - if (which .eq. 'LM') then - call dsortc ('LR', .true., kev+np, ritzr, ritzi, bounds) - else if (which .eq. 'SM') then - call dsortc ('SR', .true., kev+np, ritzr, ritzi, bounds) - else if (which .eq. 'LR') then - call dsortc ('LM', .true., kev+np, ritzr, ritzi, bounds) - else if (which .eq. 'SR') then - call dsortc ('SM', .true., kev+np, ritzr, ritzi, bounds) - else if (which .eq. 'LI') then - call dsortc ('LM', .true., kev+np, ritzr, ritzi, bounds) - else if (which .eq. 'SI') then - call dsortc ('SM', .true., kev+np, ritzr, ritzi, bounds) - end if -c - call dsortc (which, .true., kev+np, ritzr, ritzi, bounds) -c -c %-------------------------------------------------------% -c | Increase KEV by one if the ( ritzr(np),ritzi(np) ) | -c | = ( ritzr(np+1),-ritzi(np+1) ) and ritz(np) .ne. zero | -c | Accordingly decrease NP by one. In other words keep | -c | complex conjugate pairs together. | -c %-------------------------------------------------------% -c - if ( ( ritzr(np+1) - ritzr(np) ) .eq. zero - & .and. ( ritzi(np+1) + ritzi(np) ) .eq. zero ) then - np = np - 1 - kev = kev + 1 - end if -c - if ( ishift .eq. 1 ) then -c -c %-------------------------------------------------------% -c | Sort the unwanted Ritz values used as shifts so that | -c | the ones with largest Ritz estimates are first | -c | This will tend to minimize the effects of the | -c | forward instability of the iteration when they shifts | -c | are applied in subroutine dnapps. | -c | Be careful and use 'SR' since we want to sort BOUNDS! | -c %-------------------------------------------------------% -c - call dsortc ( 'SR', .true., np, bounds, ritzr, ritzi ) - end if -c - call arscnd (t1) - tngets = tngets + (t1 - t0) -c - if (msglvl .gt. 0) then - call ivout (logfil, 1, kev, ndigit, '_ngets: KEV is') - call ivout (logfil, 1, np, ndigit, '_ngets: NP is') - call dvout (logfil, kev+np, ritzr, ndigit, - & '_ngets: Eigenvalues of current H matrix -- real part') - call dvout (logfil, kev+np, ritzi, ndigit, - & '_ngets: Eigenvalues of current H matrix -- imag part') - call dvout (logfil, kev+np, bounds, ndigit, - & '_ngets: Ritz estimates of the current KEV+NP Ritz values') - end if -c - return -c -c %---------------% -c | End of dngets | -c %---------------% -c - end
--- a/libcruft/arpack/src/dsaitr.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,853 +0,0 @@ -c----------------------------------------------------------------------- -c\BeginDoc -c -c\Name: dsaitr -c -c\Description: -c Reverse communication interface for applying NP additional steps to -c a K step symmetric Arnoldi factorization. -c -c Input: OP*V_{k} - V_{k}*H = r_{k}*e_{k}^T -c -c with (V_{k}^T)*B*V_{k} = I, (V_{k}^T)*B*r_{k} = 0. -c -c Output: OP*V_{k+p} - V_{k+p}*H = r_{k+p}*e_{k+p}^T -c -c with (V_{k+p}^T)*B*V_{k+p} = I, (V_{k+p}^T)*B*r_{k+p} = 0. -c -c where OP and B are as in dsaupd. The B-norm of r_{k+p} is also -c computed and returned. -c -c\Usage: -c call dsaitr -c ( IDO, BMAT, N, K, NP, MODE, RESID, RNORM, V, LDV, H, LDH, -c IPNTR, WORKD, INFO ) -c -c\Arguments -c IDO Integer. (INPUT/OUTPUT) -c Reverse communication flag. -c ------------------------------------------------------------- -c IDO = 0: first call to the reverse communication interface -c IDO = -1: compute Y = OP * X where -c IPNTR(1) is the pointer into WORK for X, -c IPNTR(2) is the pointer into WORK for Y. -c This is for the restart phase to force the new -c starting vector into the range of OP. -c IDO = 1: compute Y = OP * X where -c IPNTR(1) is the pointer into WORK for X, -c IPNTR(2) is the pointer into WORK for Y, -c IPNTR(3) is the pointer into WORK for B * X. -c IDO = 2: compute Y = B * X where -c IPNTR(1) is the pointer into WORK for X, -c IPNTR(2) is the pointer into WORK for Y. -c IDO = 99: done -c ------------------------------------------------------------- -c When the routine is used in the "shift-and-invert" mode, the -c vector B * Q is already available and does not need to be -c recomputed in forming OP * Q. -c -c BMAT Character*1. (INPUT) -c BMAT specifies the type of matrix B that defines the -c semi-inner product for the operator OP. See dsaupd. -c B = 'I' -> standard eigenvalue problem A*x = lambda*x -c B = 'G' -> generalized eigenvalue problem A*x = lambda*M*x -c -c N Integer. (INPUT) -c Dimension of the eigenproblem. -c -c K Integer. (INPUT) -c Current order of H and the number of columns of V. -c -c NP Integer. (INPUT) -c Number of additional Arnoldi steps to take. -c -c MODE Integer. (INPUT) -c Signifies which form for "OP". If MODE=2 then -c a reduction in the number of B matrix vector multiplies -c is possible since the B-norm of OP*x is equivalent to -c the inv(B)-norm of A*x. -c -c RESID Double precision array of length N. (INPUT/OUTPUT) -c On INPUT: RESID contains the residual vector r_{k}. -c On OUTPUT: RESID contains the residual vector r_{k+p}. -c -c RNORM Double precision scalar. (INPUT/OUTPUT) -c On INPUT the B-norm of r_{k}. -c On OUTPUT the B-norm of the updated residual r_{k+p}. -c -c V Double precision N by K+NP array. (INPUT/OUTPUT) -c On INPUT: V contains the Arnoldi vectors in the first K -c columns. -c On OUTPUT: V contains the new NP Arnoldi vectors in the next -c NP columns. The first K columns are unchanged. -c -c LDV Integer. (INPUT) -c Leading dimension of V exactly as declared in the calling -c program. -c -c H Double precision (K+NP) by 2 array. (INPUT/OUTPUT) -c H is used to store the generated symmetric tridiagonal matrix -c with the subdiagonal in the first column starting at H(2,1) -c and the main diagonal in the second column. -c -c LDH Integer. (INPUT) -c Leading dimension of H exactly as declared in the calling -c program. -c -c IPNTR Integer array of length 3. (OUTPUT) -c Pointer to mark the starting locations in the WORK for -c vectors used by the Arnoldi iteration. -c ------------------------------------------------------------- -c IPNTR(1): pointer to the current operand vector X. -c IPNTR(2): pointer to the current result vector Y. -c IPNTR(3): pointer to the vector B * X when used in the -c shift-and-invert mode. X is the current operand. -c ------------------------------------------------------------- -c -c WORKD Double precision work array of length 3*N. (REVERSE COMMUNICATION) -c Distributed array to be used in the basic Arnoldi iteration -c for reverse communication. The calling program should not -c use WORKD as temporary workspace during the iteration !!!!!! -c On INPUT, WORKD(1:N) = B*RESID where RESID is associated -c with the K step Arnoldi factorization. Used to save some -c computation at the first step. -c On OUTPUT, WORKD(1:N) = B*RESID where RESID is associated -c with the K+NP step Arnoldi factorization. -c -c INFO Integer. (OUTPUT) -c = 0: Normal exit. -c > 0: Size of an invariant subspace of OP is found that is -c less than K + NP. -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Local variables: -c xxxxxx real -c -c\Routines called: -c dgetv0 ARPACK routine to generate the initial vector. -c ivout ARPACK utility routine that prints integers. -c dmout ARPACK utility routine that prints matrices. -c dvout ARPACK utility routine that prints vectors. -c dlamch LAPACK routine that determines machine constants. -c dlascl LAPACK routine for careful scaling of a matrix. -c dgemv Level 2 BLAS routine for matrix vector multiplication. -c daxpy Level 1 BLAS that computes a vector triad. -c dscal Level 1 BLAS that scales a vector. -c dcopy Level 1 BLAS that copies one vector to another . -c ddot Level 1 BLAS that computes the scalar product of two vectors. -c dnrm2 Level 1 BLAS that computes the norm of a vector. -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\Revision history: -c xx/xx/93: Version ' 2.4' -c -c\SCCS Information: @(#) -c FILE: saitr.F SID: 2.6 DATE OF SID: 8/28/96 RELEASE: 2 -c -c\Remarks -c The algorithm implemented is: -c -c restart = .false. -c Given V_{k} = [v_{1}, ..., v_{k}], r_{k}; -c r_{k} contains the initial residual vector even for k = 0; -c Also assume that rnorm = || B*r_{k} || and B*r_{k} are already -c computed by the calling program. -c -c betaj = rnorm ; p_{k+1} = B*r_{k} ; -c For j = k+1, ..., k+np Do -c 1) if ( betaj < tol ) stop or restart depending on j. -c if ( restart ) generate a new starting vector. -c 2) v_{j} = r(j-1)/betaj; V_{j} = [V_{j-1}, v_{j}]; -c p_{j} = p_{j}/betaj -c 3) r_{j} = OP*v_{j} where OP is defined as in dsaupd -c For shift-invert mode p_{j} = B*v_{j} is already available. -c wnorm = || OP*v_{j} || -c 4) Compute the j-th step residual vector. -c w_{j} = V_{j}^T * B * OP * v_{j} -c r_{j} = OP*v_{j} - V_{j} * w_{j} -c alphaj <- j-th component of w_{j} -c rnorm = || r_{j} || -c betaj+1 = rnorm -c If (rnorm > 0.717*wnorm) accept step and go back to 1) -c 5) Re-orthogonalization step: -c s = V_{j}'*B*r_{j} -c r_{j} = r_{j} - V_{j}*s; rnorm1 = || r_{j} || -c alphaj = alphaj + s_{j}; -c 6) Iterative refinement step: -c If (rnorm1 > 0.717*rnorm) then -c rnorm = rnorm1 -c accept step and go back to 1) -c Else -c rnorm = rnorm1 -c If this is the first time in step 6), go to 5) -c Else r_{j} lies in the span of V_{j} numerically. -c Set r_{j} = 0 and rnorm = 0; go to 1) -c EndIf -c End Do -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine dsaitr - & (ido, bmat, n, k, np, mode, resid, rnorm, v, ldv, h, ldh, - & ipntr, workd, info) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - character bmat*1 - integer ido, info, k, ldh, ldv, n, mode, np - Double precision - & rnorm -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - integer ipntr(3) - Double precision - & h(ldh,2), resid(n), v(ldv,k+np), workd(3*n) -c -c %------------% -c | Parameters | -c %------------% -c - Double precision - & one, zero - parameter (one = 1.0D+0, zero = 0.0D+0) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - logical first, orth1, orth2, rstart, step3, step4 - integer i, ierr, ipj, irj, ivj, iter, itry, j, msglvl, - & infol, jj - Double precision - & rnorm1, wnorm, safmin, temp1 - save orth1, orth2, rstart, step3, step4, - & ierr, ipj, irj, ivj, iter, itry, j, msglvl, - & rnorm1, safmin, wnorm -c -c %-----------------------% -c | Local Array Arguments | -c %-----------------------% -c - Double precision - & xtemp(2) -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external daxpy, dcopy, dscal, dgemv, dgetv0, dvout, dmout, - & dlascl, ivout, arscnd -c -c %--------------------% -c | External Functions | -c %--------------------% -c - Double precision - & ddot, dnrm2, dlamch - external ddot, dnrm2, dlamch -c -c %-----------------% -c | Data statements | -c %-----------------% -c - data first / .true. / -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c - if (first) then - first = .false. -c -c %--------------------------------% -c | safmin = safe minimum is such | -c | that 1/sfmin does not overflow | -c %--------------------------------% -c - safmin = dlamch('safmin') - end if -c - if (ido .eq. 0) then -c -c %-------------------------------% -c | Initialize timing statistics | -c | & message level for debugging | -c %-------------------------------% -c - call arscnd (t0) - msglvl = msaitr -c -c %------------------------------% -c | Initial call to this routine | -c %------------------------------% -c - info = 0 - step3 = .false. - step4 = .false. - rstart = .false. - orth1 = .false. - orth2 = .false. -c -c %--------------------------------% -c | Pointer to the current step of | -c | the factorization to build | -c %--------------------------------% -c - j = k + 1 -c -c %------------------------------------------% -c | Pointers used for reverse communication | -c | when using WORKD. | -c %------------------------------------------% -c - ipj = 1 - irj = ipj + n - ivj = irj + n - end if -c -c %-------------------------------------------------% -c | When in reverse communication mode one of: | -c | STEP3, STEP4, ORTH1, ORTH2, RSTART | -c | will be .true. | -c | STEP3: return from computing OP*v_{j}. | -c | STEP4: return from computing B-norm of OP*v_{j} | -c | ORTH1: return from computing B-norm of r_{j+1} | -c | ORTH2: return from computing B-norm of | -c | correction to the residual vector. | -c | RSTART: return from OP computations needed by | -c | dgetv0. | -c %-------------------------------------------------% -c - if (step3) go to 50 - if (step4) go to 60 - if (orth1) go to 70 - if (orth2) go to 90 - if (rstart) go to 30 -c -c %------------------------------% -c | Else this is the first step. | -c %------------------------------% -c -c %--------------------------------------------------------------% -c | | -c | A R N O L D I I T E R A T I O N L O O P | -c | | -c | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) | -c %--------------------------------------------------------------% -c - 1000 continue -c - if (msglvl .gt. 2) then - call ivout (logfil, 1, j, ndigit, - & '_saitr: generating Arnoldi vector no.') - call dvout (logfil, 1, rnorm, ndigit, - & '_saitr: B-norm of the current residual =') - end if -c -c %---------------------------------------------------------% -c | Check for exact zero. Equivalent to determing whether a | -c | j-step Arnoldi factorization is present. | -c %---------------------------------------------------------% -c - if (rnorm .gt. zero) go to 40 -c -c %---------------------------------------------------% -c | Invariant subspace found, generate a new starting | -c | vector which is orthogonal to the current Arnoldi | -c | basis and continue the iteration. | -c %---------------------------------------------------% -c - if (msglvl .gt. 0) then - call ivout (logfil, 1, j, ndigit, - & '_saitr: ****** restart at step ******') - end if -c -c %---------------------------------------------% -c | ITRY is the loop variable that controls the | -c | maximum amount of times that a restart is | -c | attempted. NRSTRT is used by stat.h | -c %---------------------------------------------% -c - nrstrt = nrstrt + 1 - itry = 1 - 20 continue - rstart = .true. - ido = 0 - 30 continue -c -c %--------------------------------------% -c | If in reverse communication mode and | -c | RSTART = .true. flow returns here. | -c %--------------------------------------% -c - call dgetv0 (ido, bmat, itry, .false., n, j, v, ldv, - & resid, rnorm, ipntr, workd, ierr) - if (ido .ne. 99) go to 9000 - if (ierr .lt. 0) then - itry = itry + 1 - if (itry .le. 3) go to 20 -c -c %------------------------------------------------% -c | Give up after several restart attempts. | -c | Set INFO to the size of the invariant subspace | -c | which spans OP and exit. | -c %------------------------------------------------% -c - info = j - 1 - call arscnd (t1) - tsaitr = tsaitr + (t1 - t0) - ido = 99 - go to 9000 - end if -c - 40 continue -c -c %---------------------------------------------------------% -c | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm | -c | Note that p_{j} = B*r_{j-1}. In order to avoid overflow | -c | when reciprocating a small RNORM, test against lower | -c | machine bound. | -c %---------------------------------------------------------% -c - call dcopy (n, resid, 1, v(1,j), 1) - if (rnorm .ge. safmin) then - temp1 = one / rnorm - call dscal (n, temp1, v(1,j), 1) - call dscal (n, temp1, workd(ipj), 1) - else -c -c %-----------------------------------------% -c | To scale both v_{j} and p_{j} carefully | -c | use LAPACK routine SLASCL | -c %-----------------------------------------% -c - call dlascl ('General', i, i, rnorm, one, n, 1, - & v(1,j), n, infol) - call dlascl ('General', i, i, rnorm, one, n, 1, - & workd(ipj), n, infol) - end if -c -c %------------------------------------------------------% -c | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} | -c | Note that this is not quite yet r_{j}. See STEP 4 | -c %------------------------------------------------------% -c - step3 = .true. - nopx = nopx + 1 - call arscnd (t2) - call dcopy (n, v(1,j), 1, workd(ivj), 1) - ipntr(1) = ivj - ipntr(2) = irj - ipntr(3) = ipj - ido = 1 -c -c %-----------------------------------% -c | Exit in order to compute OP*v_{j} | -c %-----------------------------------% -c - go to 9000 - 50 continue -c -c %-----------------------------------% -c | Back from reverse communication; | -c | WORKD(IRJ:IRJ+N-1) := OP*v_{j}. | -c %-----------------------------------% -c - call arscnd (t3) - tmvopx = tmvopx + (t3 - t2) -c - step3 = .false. -c -c %------------------------------------------% -c | Put another copy of OP*v_{j} into RESID. | -c %------------------------------------------% -c - call dcopy (n, workd(irj), 1, resid, 1) -c -c %-------------------------------------------% -c | STEP 4: Finish extending the symmetric | -c | Arnoldi to length j. If MODE = 2 | -c | then B*OP = B*inv(B)*A = A and | -c | we don't need to compute B*OP. | -c | NOTE: If MODE = 2 WORKD(IVJ:IVJ+N-1) is | -c | assumed to have A*v_{j}. | -c %-------------------------------------------% -c - if (mode .eq. 2) go to 65 - call arscnd (t2) - if (bmat .eq. 'G') then - nbx = nbx + 1 - step4 = .true. - ipntr(1) = irj - ipntr(2) = ipj - ido = 2 -c -c %-------------------------------------% -c | Exit in order to compute B*OP*v_{j} | -c %-------------------------------------% -c - go to 9000 - else if (bmat .eq. 'I') then - call dcopy(n, resid, 1 , workd(ipj), 1) - end if - 60 continue -c -c %-----------------------------------% -c | Back from reverse communication; | -c | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j}. | -c %-----------------------------------% -c - if (bmat .eq. 'G') then - call arscnd (t3) - tmvbx = tmvbx + (t3 - t2) - end if -c - step4 = .false. -c -c %-------------------------------------% -c | The following is needed for STEP 5. | -c | Compute the B-norm of OP*v_{j}. | -c %-------------------------------------% -c - 65 continue - if (mode .eq. 2) then -c -c %----------------------------------% -c | Note that the B-norm of OP*v_{j} | -c | is the inv(B)-norm of A*v_{j}. | -c %----------------------------------% -c - wnorm = ddot (n, resid, 1, workd(ivj), 1) - wnorm = sqrt(abs(wnorm)) - else if (bmat .eq. 'G') then - wnorm = ddot (n, resid, 1, workd(ipj), 1) - wnorm = sqrt(abs(wnorm)) - else if (bmat .eq. 'I') then - wnorm = dnrm2(n, resid, 1) - end if -c -c %-----------------------------------------% -c | Compute the j-th residual corresponding | -c | to the j step factorization. | -c | Use Classical Gram Schmidt and compute: | -c | w_{j} <- V_{j}^T * B * OP * v_{j} | -c | r_{j} <- OP*v_{j} - V_{j} * w_{j} | -c %-----------------------------------------% -c -c -c %------------------------------------------% -c | Compute the j Fourier coefficients w_{j} | -c | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. | -c %------------------------------------------% -c - if (mode .ne. 2 ) then - call dgemv('T', n, j, one, v, ldv, workd(ipj), 1, zero, - & workd(irj), 1) - else if (mode .eq. 2) then - call dgemv('T', n, j, one, v, ldv, workd(ivj), 1, zero, - & workd(irj), 1) - end if -c -c %--------------------------------------% -c | Orthgonalize r_{j} against V_{j}. | -c | RESID contains OP*v_{j}. See STEP 3. | -c %--------------------------------------% -c - call dgemv('N', n, j, -one, v, ldv, workd(irj), 1, one, - & resid, 1) -c -c %--------------------------------------% -c | Extend H to have j rows and columns. | -c %--------------------------------------% -c - h(j,2) = workd(irj + j - 1) - if (j .eq. 1 .or. rstart) then - h(j,1) = zero - else - h(j,1) = rnorm - end if - call arscnd (t4) -c - orth1 = .true. - iter = 0 -c - call arscnd (t2) - if (bmat .eq. 'G') then - nbx = nbx + 1 - call dcopy (n, resid, 1, workd(irj), 1) - ipntr(1) = irj - ipntr(2) = ipj - ido = 2 -c -c %----------------------------------% -c | Exit in order to compute B*r_{j} | -c %----------------------------------% -c - go to 9000 - else if (bmat .eq. 'I') then - call dcopy (n, resid, 1, workd(ipj), 1) - end if - 70 continue -c -c %---------------------------------------------------% -c | Back from reverse communication if ORTH1 = .true. | -c | WORKD(IPJ:IPJ+N-1) := B*r_{j}. | -c %---------------------------------------------------% -c - if (bmat .eq. 'G') then - call arscnd (t3) - tmvbx = tmvbx + (t3 - t2) - end if -c - orth1 = .false. -c -c %------------------------------% -c | Compute the B-norm of r_{j}. | -c %------------------------------% -c - if (bmat .eq. 'G') then - rnorm = ddot (n, resid, 1, workd(ipj), 1) - rnorm = sqrt(abs(rnorm)) - else if (bmat .eq. 'I') then - rnorm = dnrm2(n, resid, 1) - end if -c -c %-----------------------------------------------------------% -c | STEP 5: Re-orthogonalization / Iterative refinement phase | -c | Maximum NITER_ITREF tries. | -c | | -c | s = V_{j}^T * B * r_{j} | -c | r_{j} = r_{j} - V_{j}*s | -c | alphaj = alphaj + s_{j} | -c | | -c | The stopping criteria used for iterative refinement is | -c | discussed in Parlett's book SEP, page 107 and in Gragg & | -c | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. | -c | Determine if we need to correct the residual. The goal is | -c | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || | -c %-----------------------------------------------------------% -c - if (rnorm .gt. 0.717*wnorm) go to 100 - nrorth = nrorth + 1 -c -c %---------------------------------------------------% -c | Enter the Iterative refinement phase. If further | -c | refinement is necessary, loop back here. The loop | -c | variable is ITER. Perform a step of Classical | -c | Gram-Schmidt using all the Arnoldi vectors V_{j} | -c %---------------------------------------------------% -c - 80 continue -c - if (msglvl .gt. 2) then - xtemp(1) = wnorm - xtemp(2) = rnorm - call dvout (logfil, 2, xtemp, ndigit, - & '_saitr: re-orthonalization ; wnorm and rnorm are') - end if -c -c %----------------------------------------------------% -c | Compute V_{j}^T * B * r_{j}. | -c | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). | -c %----------------------------------------------------% -c - call dgemv ('T', n, j, one, v, ldv, workd(ipj), 1, - & zero, workd(irj), 1) -c -c %----------------------------------------------% -c | Compute the correction to the residual: | -c | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). | -c | The correction to H is v(:,1:J)*H(1:J,1:J) + | -c | v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j, but only | -c | H(j,j) is updated. | -c %----------------------------------------------% -c - call dgemv ('N', n, j, -one, v, ldv, workd(irj), 1, - & one, resid, 1) -c - if (j .eq. 1 .or. rstart) h(j,1) = zero - h(j,2) = h(j,2) + workd(irj + j - 1) -c - orth2 = .true. - call arscnd (t2) - if (bmat .eq. 'G') then - nbx = nbx + 1 - call dcopy (n, resid, 1, workd(irj), 1) - ipntr(1) = irj - ipntr(2) = ipj - ido = 2 -c -c %-----------------------------------% -c | Exit in order to compute B*r_{j}. | -c | r_{j} is the corrected residual. | -c %-----------------------------------% -c - go to 9000 - else if (bmat .eq. 'I') then - call dcopy (n, resid, 1, workd(ipj), 1) - end if - 90 continue -c -c %---------------------------------------------------% -c | Back from reverse communication if ORTH2 = .true. | -c %---------------------------------------------------% -c - if (bmat .eq. 'G') then - call arscnd (t3) - tmvbx = tmvbx + (t3 - t2) - end if -c -c %-----------------------------------------------------% -c | Compute the B-norm of the corrected residual r_{j}. | -c %-----------------------------------------------------% -c - if (bmat .eq. 'G') then - rnorm1 = ddot (n, resid, 1, workd(ipj), 1) - rnorm1 = sqrt(abs(rnorm1)) - else if (bmat .eq. 'I') then - rnorm1 = dnrm2(n, resid, 1) - end if -c - if (msglvl .gt. 0 .and. iter .gt. 0) then - call ivout (logfil, 1, j, ndigit, - & '_saitr: Iterative refinement for Arnoldi residual') - if (msglvl .gt. 2) then - xtemp(1) = rnorm - xtemp(2) = rnorm1 - call dvout (logfil, 2, xtemp, ndigit, - & '_saitr: iterative refinement ; rnorm and rnorm1 are') - end if - end if -c -c %-----------------------------------------% -c | Determine if we need to perform another | -c | step of re-orthogonalization. | -c %-----------------------------------------% -c - if (rnorm1 .gt. 0.717*rnorm) then -c -c %--------------------------------% -c | No need for further refinement | -c %--------------------------------% -c - rnorm = rnorm1 -c - else -c -c %-------------------------------------------% -c | Another step of iterative refinement step | -c | is required. NITREF is used by stat.h | -c %-------------------------------------------% -c - nitref = nitref + 1 - rnorm = rnorm1 - iter = iter + 1 - if (iter .le. 1) go to 80 -c -c %-------------------------------------------------% -c | Otherwise RESID is numerically in the span of V | -c %-------------------------------------------------% -c - do 95 jj = 1, n - resid(jj) = zero - 95 continue - rnorm = zero - end if -c -c %----------------------------------------------% -c | Branch here directly if iterative refinement | -c | wasn't necessary or after at most NITER_REF | -c | steps of iterative refinement. | -c %----------------------------------------------% -c - 100 continue -c - rstart = .false. - orth2 = .false. -c - call arscnd (t5) - titref = titref + (t5 - t4) -c -c %----------------------------------------------------------% -c | Make sure the last off-diagonal element is non negative | -c | If not perform a similarity transformation on H(1:j,1:j) | -c | and scale v(:,j) by -1. | -c %----------------------------------------------------------% -c - if (h(j,1) .lt. zero) then - h(j,1) = -h(j,1) - if ( j .lt. k+np) then - call dscal(n, -one, v(1,j+1), 1) - else - call dscal(n, -one, resid, 1) - end if - end if -c -c %------------------------------------% -c | STEP 6: Update j = j+1; Continue | -c %------------------------------------% -c - j = j + 1 - if (j .gt. k+np) then - call arscnd (t1) - tsaitr = tsaitr + (t1 - t0) - ido = 99 -c - if (msglvl .gt. 1) then - call dvout (logfil, k+np, h(1,2), ndigit, - & '_saitr: main diagonal of matrix H of step K+NP.') - if (k+np .gt. 1) then - call dvout (logfil, k+np-1, h(2,1), ndigit, - & '_saitr: sub diagonal of matrix H of step K+NP.') - end if - end if -c - go to 9000 - end if -c -c %--------------------------------------------------------% -c | Loop back to extend the factorization by another step. | -c %--------------------------------------------------------% -c - go to 1000 -c -c %---------------------------------------------------------------% -c | | -c | E N D O F M A I N I T E R A T I O N L O O P | -c | | -c %---------------------------------------------------------------% -c - 9000 continue - return -c -c %---------------% -c | End of dsaitr | -c %---------------% -c - end
--- a/libcruft/arpack/src/dsapps.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,516 +0,0 @@ -c----------------------------------------------------------------------- -c\BeginDoc -c -c\Name: dsapps -c -c\Description: -c Given the Arnoldi factorization -c -c A*V_{k} - V_{k}*H_{k} = r_{k+p}*e_{k+p}^T, -c -c apply NP shifts implicitly resulting in -c -c A*(V_{k}*Q) - (V_{k}*Q)*(Q^T* H_{k}*Q) = r_{k+p}*e_{k+p}^T * Q -c -c where Q is an orthogonal matrix of order KEV+NP. Q is the product of -c rotations resulting from the NP bulge chasing sweeps. The updated Arnoldi -c factorization becomes: -c -c A*VNEW_{k} - VNEW_{k}*HNEW_{k} = rnew_{k}*e_{k}^T. -c -c\Usage: -c call dsapps -c ( N, KEV, NP, SHIFT, V, LDV, H, LDH, RESID, Q, LDQ, WORKD ) -c -c\Arguments -c N Integer. (INPUT) -c Problem size, i.e. dimension of matrix A. -c -c KEV Integer. (INPUT) -c INPUT: KEV+NP is the size of the input matrix H. -c OUTPUT: KEV is the size of the updated matrix HNEW. -c -c NP Integer. (INPUT) -c Number of implicit shifts to be applied. -c -c SHIFT Double precision array of length NP. (INPUT) -c The shifts to be applied. -c -c V Double precision N by (KEV+NP) array. (INPUT/OUTPUT) -c INPUT: V contains the current KEV+NP Arnoldi vectors. -c OUTPUT: VNEW = V(1:n,1:KEV); the updated Arnoldi vectors -c are in the first KEV columns of V. -c -c LDV Integer. (INPUT) -c Leading dimension of V exactly as declared in the calling -c program. -c -c H Double precision (KEV+NP) by 2 array. (INPUT/OUTPUT) -c INPUT: H contains the symmetric tridiagonal matrix of the -c Arnoldi factorization with the subdiagonal in the 1st column -c starting at H(2,1) and the main diagonal in the 2nd column. -c OUTPUT: H contains the updated tridiagonal matrix in the -c KEV leading submatrix. -c -c LDH Integer. (INPUT) -c Leading dimension of H exactly as declared in the calling -c program. -c -c RESID Double precision array of length (N). (INPUT/OUTPUT) -c INPUT: RESID contains the the residual vector r_{k+p}. -c OUTPUT: RESID is the updated residual vector rnew_{k}. -c -c Q Double precision KEV+NP by KEV+NP work array. (WORKSPACE) -c Work array used to accumulate the rotations during the bulge -c chase sweep. -c -c LDQ Integer. (INPUT) -c Leading dimension of Q exactly as declared in the calling -c program. -c -c WORKD Double precision work array of length 2*N. (WORKSPACE) -c Distributed array used in the application of the accumulated -c orthogonal matrix Q. -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Local variables: -c xxxxxx real -c -c\References: -c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in -c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), -c pp 357-385. -c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly -c Restarted Arnoldi Iteration", Rice University Technical Report -c TR95-13, Department of Computational and Applied Mathematics. -c -c\Routines called: -c ivout ARPACK utility routine that prints integers. -c arscnd ARPACK utility routine for timing. -c dvout ARPACK utility routine that prints vectors. -c dlamch LAPACK routine that determines machine constants. -c dlartg LAPACK Givens rotation construction routine. -c dlacpy LAPACK matrix copy routine. -c dlaset LAPACK matrix initialization routine. -c dgemv Level 2 BLAS routine for matrix vector multiplication. -c daxpy Level 1 BLAS that computes a vector triad. -c dcopy Level 1 BLAS that copies one vector to another. -c dscal Level 1 BLAS that scales a vector. -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\Revision history: -c 12/16/93: Version ' 2.4' -c -c\SCCS Information: @(#) -c FILE: sapps.F SID: 2.6 DATE OF SID: 3/28/97 RELEASE: 2 -c -c\Remarks -c 1. In this version, each shift is applied to all the subblocks of -c the tridiagonal matrix H and not just to the submatrix that it -c comes from. This routine assumes that the subdiagonal elements -c of H that are stored in h(1:kev+np,1) are nonegative upon input -c and enforce this condition upon output. This version incorporates -c deflation. See code for documentation. -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine dsapps - & ( n, kev, np, shift, v, ldv, h, ldh, resid, q, ldq, workd ) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - integer kev, ldh, ldq, ldv, n, np -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - Double precision - & h(ldh,2), q(ldq,kev+np), resid(n), shift(np), - & v(ldv,kev+np), workd(2*n) -c -c %------------% -c | Parameters | -c %------------% -c - Double precision - & one, zero - parameter (one = 1.0D+0, zero = 0.0D+0) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - integer i, iend, istart, itop, j, jj, kplusp, msglvl - logical first - Double precision - & a1, a2, a3, a4, big, c, epsmch, f, g, r, s - save epsmch, first -c -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external daxpy, dcopy, dscal, dlacpy, dlartg, dlaset, dvout, - & ivout, arscnd, dgemv -c -c %--------------------% -c | External Functions | -c %--------------------% -c - Double precision - & dlamch - external dlamch -c -c %----------------------% -c | Intrinsics Functions | -c %----------------------% -c - intrinsic abs -c -c %----------------% -c | Data statments | -c %----------------% -c - data first / .true. / -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c - if (first) then - epsmch = dlamch('Epsilon-Machine') - first = .false. - end if - itop = 1 -c -c %-------------------------------% -c | Initialize timing statistics | -c | & message level for debugging | -c %-------------------------------% -c - call arscnd (t0) - msglvl = msapps -c - kplusp = kev + np -c -c %----------------------------------------------% -c | Initialize Q to the identity matrix of order | -c | kplusp used to accumulate the rotations. | -c %----------------------------------------------% -c - call dlaset ('All', kplusp, kplusp, zero, one, q, ldq) -c -c %----------------------------------------------% -c | Quick return if there are no shifts to apply | -c %----------------------------------------------% -c - if (np .eq. 0) go to 9000 -c -c %----------------------------------------------------------% -c | Apply the np shifts implicitly. Apply each shift to the | -c | whole matrix and not just to the submatrix from which it | -c | comes. | -c %----------------------------------------------------------% -c - do 90 jj = 1, np -c - istart = itop -c -c %----------------------------------------------------------% -c | Check for splitting and deflation. Currently we consider | -c | an off-diagonal element h(i+1,1) negligible if | -c | h(i+1,1) .le. epsmch*( |h(i,2)| + |h(i+1,2)| ) | -c | for i=1:KEV+NP-1. | -c | If above condition tests true then we set h(i+1,1) = 0. | -c | Note that h(1:KEV+NP,1) are assumed to be non negative. | -c %----------------------------------------------------------% -c - 20 continue -c -c %------------------------------------------------% -c | The following loop exits early if we encounter | -c | a negligible off diagonal element. | -c %------------------------------------------------% -c - do 30 i = istart, kplusp-1 - big = abs(h(i,2)) + abs(h(i+1,2)) - if (h(i+1,1) .le. epsmch*big) then - if (msglvl .gt. 0) then - call ivout (logfil, 1, i, ndigit, - & '_sapps: deflation at row/column no.') - call ivout (logfil, 1, jj, ndigit, - & '_sapps: occured before shift number.') - call dvout (logfil, 1, h(i+1,1), ndigit, - & '_sapps: the corresponding off diagonal element') - end if - h(i+1,1) = zero - iend = i - go to 40 - end if - 30 continue - iend = kplusp - 40 continue -c - if (istart .lt. iend) then -c -c %--------------------------------------------------------% -c | Construct the plane rotation G'(istart,istart+1,theta) | -c | that attempts to drive h(istart+1,1) to zero. | -c %--------------------------------------------------------% -c - f = h(istart,2) - shift(jj) - g = h(istart+1,1) - call dlartg (f, g, c, s, r) -c -c %-------------------------------------------------------% -c | Apply rotation to the left and right of H; | -c | H <- G' * H * G, where G = G(istart,istart+1,theta). | -c | This will create a "bulge". | -c %-------------------------------------------------------% -c - a1 = c*h(istart,2) + s*h(istart+1,1) - a2 = c*h(istart+1,1) + s*h(istart+1,2) - a4 = c*h(istart+1,2) - s*h(istart+1,1) - a3 = c*h(istart+1,1) - s*h(istart,2) - h(istart,2) = c*a1 + s*a2 - h(istart+1,2) = c*a4 - s*a3 - h(istart+1,1) = c*a3 + s*a4 -c -c %----------------------------------------------------% -c | Accumulate the rotation in the matrix Q; Q <- Q*G | -c %----------------------------------------------------% -c - do 60 j = 1, min(istart+jj,kplusp) - a1 = c*q(j,istart) + s*q(j,istart+1) - q(j,istart+1) = - s*q(j,istart) + c*q(j,istart+1) - q(j,istart) = a1 - 60 continue -c -c -c %----------------------------------------------% -c | The following loop chases the bulge created. | -c | Note that the previous rotation may also be | -c | done within the following loop. But it is | -c | kept separate to make the distinction among | -c | the bulge chasing sweeps and the first plane | -c | rotation designed to drive h(istart+1,1) to | -c | zero. | -c %----------------------------------------------% -c - do 70 i = istart+1, iend-1 -c -c %----------------------------------------------% -c | Construct the plane rotation G'(i,i+1,theta) | -c | that zeros the i-th bulge that was created | -c | by G(i-1,i,theta). g represents the bulge. | -c %----------------------------------------------% -c - f = h(i,1) - g = s*h(i+1,1) -c -c %----------------------------------% -c | Final update with G(i-1,i,theta) | -c %----------------------------------% -c - h(i+1,1) = c*h(i+1,1) - call dlartg (f, g, c, s, r) -c -c %-------------------------------------------% -c | The following ensures that h(1:iend-1,1), | -c | the first iend-2 off diagonal of elements | -c | H, remain non negative. | -c %-------------------------------------------% -c - if (r .lt. zero) then - r = -r - c = -c - s = -s - end if -c -c %--------------------------------------------% -c | Apply rotation to the left and right of H; | -c | H <- G * H * G', where G = G(i,i+1,theta) | -c %--------------------------------------------% -c - h(i,1) = r -c - a1 = c*h(i,2) + s*h(i+1,1) - a2 = c*h(i+1,1) + s*h(i+1,2) - a3 = c*h(i+1,1) - s*h(i,2) - a4 = c*h(i+1,2) - s*h(i+1,1) -c - h(i,2) = c*a1 + s*a2 - h(i+1,2) = c*a4 - s*a3 - h(i+1,1) = c*a3 + s*a4 -c -c %----------------------------------------------------% -c | Accumulate the rotation in the matrix Q; Q <- Q*G | -c %----------------------------------------------------% -c - do 50 j = 1, min( i+jj, kplusp ) - a1 = c*q(j,i) + s*q(j,i+1) - q(j,i+1) = - s*q(j,i) + c*q(j,i+1) - q(j,i) = a1 - 50 continue -c - 70 continue -c - end if -c -c %--------------------------% -c | Update the block pointer | -c %--------------------------% -c - istart = iend + 1 -c -c %------------------------------------------% -c | Make sure that h(iend,1) is non-negative | -c | If not then set h(iend,1) <-- -h(iend,1) | -c | and negate the last column of Q. | -c | We have effectively carried out a | -c | similarity on transformation H | -c %------------------------------------------% -c - if (h(iend,1) .lt. zero) then - h(iend,1) = -h(iend,1) - call dscal(kplusp, -one, q(1,iend), 1) - end if -c -c %--------------------------------------------------------% -c | Apply the same shift to the next block if there is any | -c %--------------------------------------------------------% -c - if (iend .lt. kplusp) go to 20 -c -c %-----------------------------------------------------% -c | Check if we can increase the the start of the block | -c %-----------------------------------------------------% -c - do 80 i = itop, kplusp-1 - if (h(i+1,1) .gt. zero) go to 90 - itop = itop + 1 - 80 continue -c -c %-----------------------------------% -c | Finished applying the jj-th shift | -c %-----------------------------------% -c - 90 continue -c -c %------------------------------------------% -c | All shifts have been applied. Check for | -c | more possible deflation that might occur | -c | after the last shift is applied. | -c %------------------------------------------% -c - do 100 i = itop, kplusp-1 - big = abs(h(i,2)) + abs(h(i+1,2)) - if (h(i+1,1) .le. epsmch*big) then - if (msglvl .gt. 0) then - call ivout (logfil, 1, i, ndigit, - & '_sapps: deflation at row/column no.') - call dvout (logfil, 1, h(i+1,1), ndigit, - & '_sapps: the corresponding off diagonal element') - end if - h(i+1,1) = zero - end if - 100 continue -c -c %-------------------------------------------------% -c | Compute the (kev+1)-st column of (V*Q) and | -c | temporarily store the result in WORKD(N+1:2*N). | -c | This is not necessary if h(kev+1,1) = 0. | -c %-------------------------------------------------% -c - if ( h(kev+1,1) .gt. zero ) - & call dgemv ('N', n, kplusp, one, v, ldv, - & q(1,kev+1), 1, zero, workd(n+1), 1) -c -c %-------------------------------------------------------% -c | Compute column 1 to kev of (V*Q) in backward order | -c | taking advantage that Q is an upper triangular matrix | -c | with lower bandwidth np. | -c | Place results in v(:,kplusp-kev:kplusp) temporarily. | -c %-------------------------------------------------------% -c - do 130 i = 1, kev - call dgemv ('N', n, kplusp-i+1, one, v, ldv, - & q(1,kev-i+1), 1, zero, workd, 1) - call dcopy (n, workd, 1, v(1,kplusp-i+1), 1) - 130 continue -c -c %-------------------------------------------------% -c | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). | -c %-------------------------------------------------% -c - call dlacpy ('All', n, kev, v(1,np+1), ldv, v, ldv) -c -c %--------------------------------------------% -c | Copy the (kev+1)-st column of (V*Q) in the | -c | appropriate place if h(kev+1,1) .ne. zero. | -c %--------------------------------------------% -c - if ( h(kev+1,1) .gt. zero ) - & call dcopy (n, workd(n+1), 1, v(1,kev+1), 1) -c -c %-------------------------------------% -c | Update the residual vector: | -c | r <- sigmak*r + betak*v(:,kev+1) | -c | where | -c | sigmak = (e_{kev+p}'*Q)*e_{kev} | -c | betak = e_{kev+1}'*H*e_{kev} | -c %-------------------------------------% -c - call dscal (n, q(kplusp,kev), resid, 1) - if (h(kev+1,1) .gt. zero) - & call daxpy (n, h(kev+1,1), v(1,kev+1), 1, resid, 1) -c - if (msglvl .gt. 1) then - call dvout (logfil, 1, q(kplusp,kev), ndigit, - & '_sapps: sigmak of the updated residual vector') - call dvout (logfil, 1, h(kev+1,1), ndigit, - & '_sapps: betak of the updated residual vector') - call dvout (logfil, kev, h(1,2), ndigit, - & '_sapps: updated main diagonal of H for next iteration') - if (kev .gt. 1) then - call dvout (logfil, kev-1, h(2,1), ndigit, - & '_sapps: updated sub diagonal of H for next iteration') - end if - end if -c - call arscnd (t1) - tsapps = tsapps + (t1 - t0) -c - 9000 continue - return -c -c %---------------% -c | End of dsapps | -c %---------------% -c - end
--- a/libcruft/arpack/src/dsaup2.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,850 +0,0 @@ -c----------------------------------------------------------------------- -c\BeginDoc -c -c\Name: dsaup2 -c -c\Description: -c Intermediate level interface called by dsaupd. -c -c\Usage: -c call dsaup2 -c ( IDO, BMAT, N, WHICH, NEV, NP, TOL, RESID, MODE, IUPD, -c ISHIFT, MXITER, V, LDV, H, LDH, RITZ, BOUNDS, Q, LDQ, WORKL, -c IPNTR, WORKD, INFO ) -c -c\Arguments -c -c IDO, BMAT, N, WHICH, NEV, TOL, RESID: same as defined in dsaupd. -c MODE, ISHIFT, MXITER: see the definition of IPARAM in dsaupd. -c -c NP Integer. (INPUT/OUTPUT) -c Contains the number of implicit shifts to apply during -c each Arnoldi/Lanczos iteration. -c If ISHIFT=1, NP is adjusted dynamically at each iteration -c to accelerate convergence and prevent stagnation. -c This is also roughly equal to the number of matrix-vector -c products (involving the operator OP) per Arnoldi iteration. -c The logic for adjusting is contained within the current -c subroutine. -c If ISHIFT=0, NP is the number of shifts the user needs -c to provide via reverse comunication. 0 < NP < NCV-NEV. -c NP may be less than NCV-NEV since a leading block of the current -c upper Tridiagonal matrix has split off and contains "unwanted" -c Ritz values. -c Upon termination of the IRA iteration, NP contains the number -c of "converged" wanted Ritz values. -c -c IUPD Integer. (INPUT) -c IUPD .EQ. 0: use explicit restart instead implicit update. -c IUPD .NE. 0: use implicit update. -c -c V Double precision N by (NEV+NP) array. (INPUT/OUTPUT) -c The Lanczos basis vectors. -c -c LDV Integer. (INPUT) -c Leading dimension of V exactly as declared in the calling -c program. -c -c H Double precision (NEV+NP) by 2 array. (OUTPUT) -c H is used to store the generated symmetric tridiagonal matrix -c The subdiagonal is stored in the first column of H starting -c at H(2,1). The main diagonal is stored in the arscnd column -c of H starting at H(1,2). If dsaup2 converges store the -c B-norm of the final residual vector in H(1,1). -c -c LDH Integer. (INPUT) -c Leading dimension of H exactly as declared in the calling -c program. -c -c RITZ Double precision array of length NEV+NP. (OUTPUT) -c RITZ(1:NEV) contains the computed Ritz values of OP. -c -c BOUNDS Double precision array of length NEV+NP. (OUTPUT) -c BOUNDS(1:NEV) contain the error bounds corresponding to RITZ. -c -c Q Double precision (NEV+NP) by (NEV+NP) array. (WORKSPACE) -c Private (replicated) work array used to accumulate the -c rotation in the shift application step. -c -c LDQ Integer. (INPUT) -c Leading dimension of Q exactly as declared in the calling -c program. -c -c WORKL Double precision array of length at least 3*(NEV+NP). (INPUT/WORKSPACE) -c Private (replicated) array on each PE or array allocated on -c the front end. It is used in the computation of the -c tridiagonal eigenvalue problem, the calculation and -c application of the shifts and convergence checking. -c If ISHIFT .EQ. O and IDO .EQ. 3, the first NP locations -c of WORKL are used in reverse communication to hold the user -c supplied shifts. -c -c IPNTR Integer array of length 3. (OUTPUT) -c Pointer to mark the starting locations in the WORKD for -c vectors used by the Lanczos iteration. -c ------------------------------------------------------------- -c IPNTR(1): pointer to the current operand vector X. -c IPNTR(2): pointer to the current result vector Y. -c IPNTR(3): pointer to the vector B * X when used in one of -c the spectral transformation modes. X is the current -c operand. -c ------------------------------------------------------------- -c -c WORKD Double precision work array of length 3*N. (REVERSE COMMUNICATION) -c Distributed array to be used in the basic Lanczos iteration -c for reverse communication. The user should not use WORKD -c as temporary workspace during the iteration !!!!!!!!!! -c See Data Distribution Note in dsaupd. -c -c INFO Integer. (INPUT/OUTPUT) -c If INFO .EQ. 0, a randomly initial residual vector is used. -c If INFO .NE. 0, RESID contains the initial residual vector, -c possibly from a previous run. -c Error flag on output. -c = 0: Normal return. -c = 1: All possible eigenvalues of OP has been found. -c NP returns the size of the invariant subspace -c spanning the operator OP. -c = 2: No shifts could be applied. -c = -8: Error return from trid. eigenvalue calculation; -c This should never happen. -c = -9: Starting vector is zero. -c = -9999: Could not build an Lanczos factorization. -c Size that was built in returned in NP. -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\References: -c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in -c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), -c pp 357-385. -c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly -c Restarted Arnoldi Iteration", Rice University Technical Report -c TR95-13, Department of Computational and Applied Mathematics. -c 3. B.N. Parlett, "The Symmetric Eigenvalue Problem". Prentice-Hall, -c 1980. -c 4. B.N. Parlett, B. Nour-Omid, "Towards a Black Box Lanczos Program", -c Computer Physics Communications, 53 (1989), pp 169-179. -c 5. B. Nour-Omid, B.N. Parlett, T. Ericson, P.S. Jensen, "How to -c Implement the Spectral Transformation", Math. Comp., 48 (1987), -c pp 663-673. -c 6. R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos -c Algorithm for Solving Sparse Symmetric Generalized Eigenproblems", -c SIAM J. Matr. Anal. Apps., January (1993). -c 7. L. Reichel, W.B. Gragg, "Algorithm 686: FORTRAN Subroutines -c for Updating the QR decomposition", ACM TOMS, December 1990, -c Volume 16 Number 4, pp 369-377. -c -c\Routines called: -c dgetv0 ARPACK initial vector generation routine. -c dsaitr ARPACK Lanczos factorization routine. -c dsapps ARPACK application of implicit shifts routine. -c dsconv ARPACK convergence of Ritz values routine. -c dseigt ARPACK compute Ritz values and error bounds routine. -c dsgets ARPACK reorder Ritz values and error bounds routine. -c dsortr ARPACK sorting routine. -c ivout ARPACK utility routine that prints integers. -c arscnd ARPACK utility routine for timing. -c dvout ARPACK utility routine that prints vectors. -c dlamch LAPACK routine that determines machine constants. -c dcopy Level 1 BLAS that copies one vector to another. -c ddot Level 1 BLAS that computes the scalar product of two vectors. -c dnrm2 Level 1 BLAS that computes the norm of a vector. -c dscal Level 1 BLAS that scales a vector. -c dswap Level 1 BLAS that swaps two vectors. -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\Revision history: -c 12/15/93: Version ' 2.4' -c xx/xx/95: Version ' 2.4'. (R.B. Lehoucq) -c -c\SCCS Information: @(#) -c FILE: saup2.F SID: 2.7 DATE OF SID: 5/19/98 RELEASE: 2 -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine dsaup2 - & ( ido, bmat, n, which, nev, np, tol, resid, mode, iupd, - & ishift, mxiter, v, ldv, h, ldh, ritz, bounds, - & q, ldq, workl, ipntr, workd, info ) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - character bmat*1, which*2 - integer ido, info, ishift, iupd, ldh, ldq, ldv, mxiter, - & n, mode, nev, np - Double precision - & tol -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - integer ipntr(3) - Double precision - & bounds(nev+np), h(ldh,2), q(ldq,nev+np), resid(n), - & ritz(nev+np), v(ldv,nev+np), workd(3*n), - & workl(3*(nev+np)) -c -c %------------% -c | Parameters | -c %------------% -c - Double precision - & one, zero - parameter (one = 1.0D+0, zero = 0.0D+0) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - character wprime*2 - logical cnorm, getv0, initv, update, ushift - integer ierr, iter, j, kplusp, msglvl, nconv, nevbef, nev0, - & np0, nptemp, nevd2, nevm2, kp(3) - Double precision - & rnorm, temp, eps23 - save cnorm, getv0, initv, update, ushift, - & iter, kplusp, msglvl, nconv, nev0, np0, - & rnorm, eps23 -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external dcopy, dgetv0, dsaitr, dscal, dsconv, dseigt, dsgets, - & dsapps, dsortr, dvout, ivout, arscnd, dswap -c -c %--------------------% -c | External Functions | -c %--------------------% -c - Double precision - & ddot, dnrm2, dlamch - external ddot, dnrm2, dlamch -c -c %---------------------% -c | Intrinsic Functions | -c %---------------------% -c - intrinsic min -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c - if (ido .eq. 0) then -c -c %-------------------------------% -c | Initialize timing statistics | -c | & message level for debugging | -c %-------------------------------% -c - call arscnd (t0) - msglvl = msaup2 -c -c %---------------------------------% -c | Set machine dependent constant. | -c %---------------------------------% -c - eps23 = dlamch('Epsilon-Machine') - eps23 = eps23**(2.0D+0/3.0D+0) -c -c %-------------------------------------% -c | nev0 and np0 are integer variables | -c | hold the initial values of NEV & NP | -c %-------------------------------------% -c - nev0 = nev - np0 = np -c -c %-------------------------------------% -c | kplusp is the bound on the largest | -c | Lanczos factorization built. | -c | nconv is the current number of | -c | "converged" eigenvlues. | -c | iter is the counter on the current | -c | iteration step. | -c %-------------------------------------% -c - kplusp = nev0 + np0 - nconv = 0 - iter = 0 -c -c %--------------------------------------------% -c | Set flags for computing the first NEV steps | -c | of the Lanczos factorization. | -c %--------------------------------------------% -c - getv0 = .true. - update = .false. - ushift = .false. - cnorm = .false. -c - if (info .ne. 0) then -c -c %--------------------------------------------% -c | User provides the initial residual vector. | -c %--------------------------------------------% -c - initv = .true. - info = 0 - else - initv = .false. - end if - end if -c -c %---------------------------------------------% -c | Get a possibly random starting vector and | -c | force it into the range of the operator OP. | -c %---------------------------------------------% -c - 10 continue -c - if (getv0) then - call dgetv0 (ido, bmat, 1, initv, n, 1, v, ldv, resid, rnorm, - & ipntr, workd, info) -c - if (ido .ne. 99) go to 9000 -c - if (rnorm .eq. zero) then -c -c %-----------------------------------------% -c | The initial vector is zero. Error exit. | -c %-----------------------------------------% -c - info = -9 - go to 1200 - end if - getv0 = .false. - ido = 0 - end if -c -c %------------------------------------------------------------% -c | Back from reverse communication: continue with update step | -c %------------------------------------------------------------% -c - if (update) go to 20 -c -c %-------------------------------------------% -c | Back from computing user specified shifts | -c %-------------------------------------------% -c - if (ushift) go to 50 -c -c %-------------------------------------% -c | Back from computing residual norm | -c | at the end of the current iteration | -c %-------------------------------------% -c - if (cnorm) go to 100 -c -c %----------------------------------------------------------% -c | Compute the first NEV steps of the Lanczos factorization | -c %----------------------------------------------------------% -c - call dsaitr (ido, bmat, n, 0, nev0, mode, resid, rnorm, v, ldv, - & h, ldh, ipntr, workd, info) -c -c %---------------------------------------------------% -c | ido .ne. 99 implies use of reverse communication | -c | to compute operations involving OP and possibly B | -c %---------------------------------------------------% -c - if (ido .ne. 99) go to 9000 -c - if (info .gt. 0) then -c -c %-----------------------------------------------------% -c | dsaitr was unable to build an Lanczos factorization | -c | of length NEV0. INFO is returned with the size of | -c | the factorization built. Exit main loop. | -c %-----------------------------------------------------% -c - np = info - mxiter = iter - info = -9999 - go to 1200 - end if -c -c %--------------------------------------------------------------% -c | | -c | M A I N LANCZOS I T E R A T I O N L O O P | -c | Each iteration implicitly restarts the Lanczos | -c | factorization in place. | -c | | -c %--------------------------------------------------------------% -c - 1000 continue -c - iter = iter + 1 -c - if (msglvl .gt. 0) then - call ivout (logfil, 1, iter, ndigit, - & '_saup2: **** Start of major iteration number ****') - end if - if (msglvl .gt. 1) then - call ivout (logfil, 1, nev, ndigit, - & '_saup2: The length of the current Lanczos factorization') - call ivout (logfil, 1, np, ndigit, - & '_saup2: Extend the Lanczos factorization by') - end if -c -c %------------------------------------------------------------% -c | Compute NP additional steps of the Lanczos factorization. | -c %------------------------------------------------------------% -c - ido = 0 - 20 continue - update = .true. -c - call dsaitr (ido, bmat, n, nev, np, mode, resid, rnorm, v, - & ldv, h, ldh, ipntr, workd, info) -c -c %---------------------------------------------------% -c | ido .ne. 99 implies use of reverse communication | -c | to compute operations involving OP and possibly B | -c %---------------------------------------------------% -c - if (ido .ne. 99) go to 9000 -c - if (info .gt. 0) then -c -c %-----------------------------------------------------% -c | dsaitr was unable to build an Lanczos factorization | -c | of length NEV0+NP0. INFO is returned with the size | -c | of the factorization built. Exit main loop. | -c %-----------------------------------------------------% -c - np = info - mxiter = iter - info = -9999 - go to 1200 - end if - update = .false. -c - if (msglvl .gt. 1) then - call dvout (logfil, 1, rnorm, ndigit, - & '_saup2: Current B-norm of residual for factorization') - end if -c -c %--------------------------------------------------------% -c | Compute the eigenvalues and corresponding error bounds | -c | of the current symmetric tridiagonal matrix. | -c %--------------------------------------------------------% -c - call dseigt (rnorm, kplusp, h, ldh, ritz, bounds, workl, ierr) -c - if (ierr .ne. 0) then - info = -8 - go to 1200 - end if -c -c %----------------------------------------------------% -c | Make a copy of eigenvalues and corresponding error | -c | bounds obtained from _seigt. | -c %----------------------------------------------------% -c - call dcopy(kplusp, ritz, 1, workl(kplusp+1), 1) - call dcopy(kplusp, bounds, 1, workl(2*kplusp+1), 1) -c -c %---------------------------------------------------% -c | Select the wanted Ritz values and their bounds | -c | to be used in the convergence test. | -c | The selection is based on the requested number of | -c | eigenvalues instead of the current NEV and NP to | -c | prevent possible misconvergence. | -c | * Wanted Ritz values := RITZ(NP+1:NEV+NP) | -c | * Shifts := RITZ(1:NP) := WORKL(1:NP) | -c %---------------------------------------------------% -c - nev = nev0 - np = np0 - call dsgets (ishift, which, nev, np, ritz, bounds, workl) -c -c %-------------------% -c | Convergence test. | -c %-------------------% -c - call dcopy (nev, bounds(np+1), 1, workl(np+1), 1) - call dsconv (nev, ritz(np+1), workl(np+1), tol, nconv) -c - if (msglvl .gt. 2) then - kp(1) = nev - kp(2) = np - kp(3) = nconv - call ivout (logfil, 3, kp, ndigit, - & '_saup2: NEV, NP, NCONV are') - call dvout (logfil, kplusp, ritz, ndigit, - & '_saup2: The eigenvalues of H') - call dvout (logfil, kplusp, bounds, ndigit, - & '_saup2: Ritz estimates of the current NCV Ritz values') - end if -c -c %---------------------------------------------------------% -c | Count the number of unwanted Ritz values that have zero | -c | Ritz estimates. If any Ritz estimates are equal to zero | -c | then a leading block of H of order equal to at least | -c | the number of Ritz values with zero Ritz estimates has | -c | split off. None of these Ritz values may be removed by | -c | shifting. Decrease NP the number of shifts to apply. If | -c | no shifts may be applied, then prepare to exit | -c %---------------------------------------------------------% -c - nptemp = np - do 30 j=1, nptemp - if (bounds(j) .eq. zero) then - np = np - 1 - nev = nev + 1 - end if - 30 continue -c - if ( (nconv .ge. nev0) .or. - & (iter .gt. mxiter) .or. - & (np .eq. 0) ) then -c -c %------------------------------------------------% -c | Prepare to exit. Put the converged Ritz values | -c | and corresponding bounds in RITZ(1:NCONV) and | -c | BOUNDS(1:NCONV) respectively. Then sort. Be | -c | careful when NCONV > NP since we don't want to | -c | swap overlapping locations. | -c %------------------------------------------------% -c - if (which .eq. 'BE') then -c -c %-----------------------------------------------------% -c | Both ends of the spectrum are requested. | -c | Sort the eigenvalues into algebraically decreasing | -c | order first then swap low end of the spectrum next | -c | to high end in appropriate locations. | -c | NOTE: when np < floor(nev/2) be careful not to swap | -c | overlapping locations. | -c %-----------------------------------------------------% -c - wprime = 'SA' - call dsortr (wprime, .true., kplusp, ritz, bounds) - nevd2 = nev0 / 2 - nevm2 = nev0 - nevd2 - if ( nev .gt. 1 ) then - call dswap ( min(nevd2,np), ritz(nevm2+1), 1, - & ritz( max(kplusp-nevd2+1,kplusp-np+1) ), 1) - call dswap ( min(nevd2,np), bounds(nevm2+1), 1, - & bounds( max(kplusp-nevd2+1,kplusp-np+1)), 1) - end if -c - else -c -c %--------------------------------------------------% -c | LM, SM, LA, SA case. | -c | Sort the eigenvalues of H into the an order that | -c | is opposite to WHICH, and apply the resulting | -c | order to BOUNDS. The eigenvalues are sorted so | -c | that the wanted part are always within the first | -c | NEV locations. | -c %--------------------------------------------------% -c - if (which .eq. 'LM') wprime = 'SM' - if (which .eq. 'SM') wprime = 'LM' - if (which .eq. 'LA') wprime = 'SA' - if (which .eq. 'SA') wprime = 'LA' -c - call dsortr (wprime, .true., kplusp, ritz, bounds) -c - end if -c -c %--------------------------------------------------% -c | Scale the Ritz estimate of each Ritz value | -c | by 1 / max(eps23,magnitude of the Ritz value). | -c %--------------------------------------------------% -c - do 35 j = 1, nev0 - temp = max( eps23, abs(ritz(j)) ) - bounds(j) = bounds(j)/temp - 35 continue -c -c %----------------------------------------------------% -c | Sort the Ritz values according to the scaled Ritz | -c | esitmates. This will push all the converged ones | -c | towards the front of ritzr, ritzi, bounds | -c | (in the case when NCONV < NEV.) | -c %----------------------------------------------------% -c - wprime = 'LA' - call dsortr(wprime, .true., nev0, bounds, ritz) -c -c %----------------------------------------------% -c | Scale the Ritz estimate back to its original | -c | value. | -c %----------------------------------------------% -c - do 40 j = 1, nev0 - temp = max( eps23, abs(ritz(j)) ) - bounds(j) = bounds(j)*temp - 40 continue -c -c %--------------------------------------------------% -c | Sort the "converged" Ritz values again so that | -c | the "threshold" values and their associated Ritz | -c | estimates appear at the appropriate position in | -c | ritz and bound. | -c %--------------------------------------------------% -c - if (which .eq. 'BE') then -c -c %------------------------------------------------% -c | Sort the "converged" Ritz values in increasing | -c | order. The "threshold" values are in the | -c | middle. | -c %------------------------------------------------% -c - wprime = 'LA' - call dsortr(wprime, .true., nconv, ritz, bounds) -c - else -c -c %----------------------------------------------% -c | In LM, SM, LA, SA case, sort the "converged" | -c | Ritz values according to WHICH so that the | -c | "threshold" value appears at the front of | -c | ritz. | -c %----------------------------------------------% - - call dsortr(which, .true., nconv, ritz, bounds) -c - end if -c -c %------------------------------------------% -c | Use h( 1,1 ) as storage to communicate | -c | rnorm to _seupd if needed | -c %------------------------------------------% -c - h(1,1) = rnorm -c - if (msglvl .gt. 1) then - call dvout (logfil, kplusp, ritz, ndigit, - & '_saup2: Sorted Ritz values.') - call dvout (logfil, kplusp, bounds, ndigit, - & '_saup2: Sorted ritz estimates.') - end if -c -c %------------------------------------% -c | Max iterations have been exceeded. | -c %------------------------------------% -c - if (iter .gt. mxiter .and. nconv .lt. nev) info = 1 -c -c %---------------------% -c | No shifts to apply. | -c %---------------------% -c - if (np .eq. 0 .and. nconv .lt. nev0) info = 2 -c - np = nconv - go to 1100 -c - else if (nconv .lt. nev .and. ishift .eq. 1) then -c -c %---------------------------------------------------% -c | Do not have all the requested eigenvalues yet. | -c | To prevent possible stagnation, adjust the number | -c | of Ritz values and the shifts. | -c %---------------------------------------------------% -c - nevbef = nev - nev = nev + min (nconv, np/2) - if (nev .eq. 1 .and. kplusp .ge. 6) then - nev = kplusp / 2 - else if (nev .eq. 1 .and. kplusp .gt. 2) then - nev = 2 - end if - np = kplusp - nev -c -c %---------------------------------------% -c | If the size of NEV was just increased | -c | resort the eigenvalues. | -c %---------------------------------------% -c - if (nevbef .lt. nev) - & call dsgets (ishift, which, nev, np, ritz, bounds, - & workl) -c - end if -c - if (msglvl .gt. 0) then - call ivout (logfil, 1, nconv, ndigit, - & '_saup2: no. of "converged" Ritz values at this iter.') - if (msglvl .gt. 1) then - kp(1) = nev - kp(2) = np - call ivout (logfil, 2, kp, ndigit, - & '_saup2: NEV and NP are') - call dvout (logfil, nev, ritz(np+1), ndigit, - & '_saup2: "wanted" Ritz values.') - call dvout (logfil, nev, bounds(np+1), ndigit, - & '_saup2: Ritz estimates of the "wanted" values ') - end if - end if - -c - if (ishift .eq. 0) then -c -c %-----------------------------------------------------% -c | User specified shifts: reverse communication to | -c | compute the shifts. They are returned in the first | -c | NP locations of WORKL. | -c %-----------------------------------------------------% -c - ushift = .true. - ido = 3 - go to 9000 - end if -c - 50 continue -c -c %------------------------------------% -c | Back from reverse communication; | -c | User specified shifts are returned | -c | in WORKL(1:*NP) | -c %------------------------------------% -c - ushift = .false. -c -c -c %---------------------------------------------------------% -c | Move the NP shifts to the first NP locations of RITZ to | -c | free up WORKL. This is for the non-exact shift case; | -c | in the exact shift case, dsgets already handles this. | -c %---------------------------------------------------------% -c - if (ishift .eq. 0) call dcopy (np, workl, 1, ritz, 1) -c - if (msglvl .gt. 2) then - call ivout (logfil, 1, np, ndigit, - & '_saup2: The number of shifts to apply ') - call dvout (logfil, np, workl, ndigit, - & '_saup2: shifts selected') - if (ishift .eq. 1) then - call dvout (logfil, np, bounds, ndigit, - & '_saup2: corresponding Ritz estimates') - end if - end if -c -c %---------------------------------------------------------% -c | Apply the NP0 implicit shifts by QR bulge chasing. | -c | Each shift is applied to the entire tridiagonal matrix. | -c | The first 2*N locations of WORKD are used as workspace. | -c | After dsapps is done, we have a Lanczos | -c | factorization of length NEV. | -c %---------------------------------------------------------% -c - call dsapps (n, nev, np, ritz, v, ldv, h, ldh, resid, q, ldq, - & workd) -c -c %---------------------------------------------% -c | Compute the B-norm of the updated residual. | -c | Keep B*RESID in WORKD(1:N) to be used in | -c | the first step of the next call to dsaitr. | -c %---------------------------------------------% -c - cnorm = .true. - call arscnd (t2) - if (bmat .eq. 'G') then - nbx = nbx + 1 - call dcopy (n, resid, 1, workd(n+1), 1) - ipntr(1) = n + 1 - ipntr(2) = 1 - ido = 2 -c -c %----------------------------------% -c | Exit in order to compute B*RESID | -c %----------------------------------% -c - go to 9000 - else if (bmat .eq. 'I') then - call dcopy (n, resid, 1, workd, 1) - end if -c - 100 continue -c -c %----------------------------------% -c | Back from reverse communication; | -c | WORKD(1:N) := B*RESID | -c %----------------------------------% -c - if (bmat .eq. 'G') then - call arscnd (t3) - tmvbx = tmvbx + (t3 - t2) - end if -c - if (bmat .eq. 'G') then - rnorm = ddot (n, resid, 1, workd, 1) - rnorm = sqrt(abs(rnorm)) - else if (bmat .eq. 'I') then - rnorm = dnrm2(n, resid, 1) - end if - cnorm = .false. - 130 continue -c - if (msglvl .gt. 2) then - call dvout (logfil, 1, rnorm, ndigit, - & '_saup2: B-norm of residual for NEV factorization') - call dvout (logfil, nev, h(1,2), ndigit, - & '_saup2: main diagonal of compressed H matrix') - call dvout (logfil, nev-1, h(2,1), ndigit, - & '_saup2: subdiagonal of compressed H matrix') - end if -c - go to 1000 -c -c %---------------------------------------------------------------% -c | | -c | E N D O F M A I N I T E R A T I O N L O O P | -c | | -c %---------------------------------------------------------------% -c - 1100 continue -c - mxiter = iter - nev = nconv -c - 1200 continue - ido = 99 -c -c %------------% -c | Error exit | -c %------------% -c - call arscnd (t1) - tsaup2 = t1 - t0 -c - 9000 continue - return -c -c %---------------% -c | End of dsaup2 | -c %---------------% -c - end
--- a/libcruft/arpack/src/dsaupd.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,690 +0,0 @@ -c----------------------------------------------------------------------- -c\BeginDoc -c -c\Name: dsaupd -c -c\Description: -c -c Reverse communication interface for the Implicitly Restarted Arnoldi -c Iteration. For symmetric problems this reduces to a variant of the Lanczos -c method. This method has been designed to compute approximations to a -c few eigenpairs of a linear operator OP that is real and symmetric -c with respect to a real positive semi-definite symmetric matrix B, -c i.e. -c -c B*OP = (OP`)*B. -c -c Another way to express this condition is -c -c < x,OPy > = < OPx,y > where < z,w > = z`Bw . -c -c In the standard eigenproblem B is the identity matrix. -c ( A` denotes transpose of A) -c -c The computed approximate eigenvalues are called Ritz values and -c the corresponding approximate eigenvectors are called Ritz vectors. -c -c dsaupd is usually called iteratively to solve one of the -c following problems: -c -c Mode 1: A*x = lambda*x, A symmetric -c ===> OP = A and B = I. -c -c Mode 2: A*x = lambda*M*x, A symmetric, M symmetric positive definite -c ===> OP = inv[M]*A and B = M. -c ===> (If M can be factored see remark 3 below) -c -c Mode 3: K*x = lambda*M*x, K symmetric, M symmetric positive semi-definite -c ===> OP = (inv[K - sigma*M])*M and B = M. -c ===> Shift-and-Invert mode -c -c Mode 4: K*x = lambda*KG*x, K symmetric positive semi-definite, -c KG symmetric indefinite -c ===> OP = (inv[K - sigma*KG])*K and B = K. -c ===> Buckling mode -c -c Mode 5: A*x = lambda*M*x, A symmetric, M symmetric positive semi-definite -c ===> OP = inv[A - sigma*M]*[A + sigma*M] and B = M. -c ===> Cayley transformed mode -c -c NOTE: The action of w <- inv[A - sigma*M]*v or w <- inv[M]*v -c should be accomplished either by a direct method -c using a sparse matrix factorization and solving -c -c [A - sigma*M]*w = v or M*w = v, -c -c or through an iterative method for solving these -c systems. If an iterative method is used, the -c convergence test must be more stringent than -c the accuracy requirements for the eigenvalue -c approximations. -c -c\Usage: -c call dsaupd -c ( IDO, BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, -c IPNTR, WORKD, WORKL, LWORKL, INFO ) -c -c\Arguments -c IDO Integer. (INPUT/OUTPUT) -c Reverse communication flag. IDO must be zero on the first -c call to dsaupd . IDO will be set internally to -c indicate the type of operation to be performed. Control is -c then given back to the calling routine which has the -c responsibility to carry out the requested operation and call -c dsaupd with the result. The operand is given in -c WORKD(IPNTR(1)), the result must be put in WORKD(IPNTR(2)). -c (If Mode = 2 see remark 5 below) -c ------------------------------------------------------------- -c IDO = 0: first call to the reverse communication interface -c IDO = -1: compute Y = OP * X where -c IPNTR(1) is the pointer into WORKD for X, -c IPNTR(2) is the pointer into WORKD for Y. -c This is for the initialization phase to force the -c starting vector into the range of OP. -c IDO = 1: compute Y = OP * X where -c IPNTR(1) is the pointer into WORKD for X, -c IPNTR(2) is the pointer into WORKD for Y. -c In mode 3,4 and 5, the vector B * X is already -c available in WORKD(ipntr(3)). It does not -c need to be recomputed in forming OP * X. -c IDO = 2: compute Y = B * X where -c IPNTR(1) is the pointer into WORKD for X, -c IPNTR(2) is the pointer into WORKD for Y. -c IDO = 3: compute the IPARAM(8) shifts where -c IPNTR(11) is the pointer into WORKL for -c placing the shifts. See remark 6 below. -c IDO = 99: done -c ------------------------------------------------------------- -c -c BMAT Character*1. (INPUT) -c BMAT specifies the type of the matrix B that defines the -c semi-inner product for the operator OP. -c B = 'I' -> standard eigenvalue problem A*x = lambda*x -c B = 'G' -> generalized eigenvalue problem A*x = lambda*B*x -c -c N Integer. (INPUT) -c Dimension of the eigenproblem. -c -c WHICH Character*2. (INPUT) -c Specify which of the Ritz values of OP to compute. -c -c 'LA' - compute the NEV largest (algebraic) eigenvalues. -c 'SA' - compute the NEV smallest (algebraic) eigenvalues. -c 'LM' - compute the NEV largest (in magnitude) eigenvalues. -c 'SM' - compute the NEV smallest (in magnitude) eigenvalues. -c 'BE' - compute NEV eigenvalues, half from each end of the -c spectrum. When NEV is odd, compute one more from the -c high end than from the low end. -c (see remark 1 below) -c -c NEV Integer. (INPUT) -c Number of eigenvalues of OP to be computed. 0 < NEV < N. -c -c TOL Double precision scalar. (INPUT) -c Stopping criterion: the relative accuracy of the Ritz value -c is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I)). -c If TOL .LE. 0. is passed a default is set: -c DEFAULT = DLAMCH ('EPS') (machine precision as computed -c by the LAPACK auxiliary subroutine DLAMCH ). -c -c RESID Double precision array of length N. (INPUT/OUTPUT) -c On INPUT: -c If INFO .EQ. 0, a random initial residual vector is used. -c If INFO .NE. 0, RESID contains the initial residual vector, -c possibly from a previous run. -c On OUTPUT: -c RESID contains the final residual vector. -c -c NCV Integer. (INPUT) -c Number of columns of the matrix V (less than or equal to N). -c This will indicate how many Lanczos vectors are generated -c at each iteration. After the startup phase in which NEV -c Lanczos vectors are generated, the algorithm generates -c NCV-NEV Lanczos vectors at each subsequent update iteration. -c Most of the cost in generating each Lanczos vector is in the -c matrix-vector product OP*x. (See remark 4 below). -c -c V Double precision N by NCV array. (OUTPUT) -c The NCV columns of V contain the Lanczos basis vectors. -c -c LDV Integer. (INPUT) -c Leading dimension of V exactly as declared in the calling -c program. -c -c IPARAM Integer array of length 11. (INPUT/OUTPUT) -c IPARAM(1) = ISHIFT: method for selecting the implicit shifts. -c The shifts selected at each iteration are used to restart -c the Arnoldi iteration in an implicit fashion. -c ------------------------------------------------------------- -c ISHIFT = 0: the shifts are provided by the user via -c reverse communication. The NCV eigenvalues of -c the current tridiagonal matrix T are returned in -c the part of WORKL array corresponding to RITZ. -c See remark 6 below. -c ISHIFT = 1: exact shifts with respect to the reduced -c tridiagonal matrix T. This is equivalent to -c restarting the iteration with a starting vector -c that is a linear combination of Ritz vectors -c associated with the "wanted" Ritz values. -c ------------------------------------------------------------- -c -c IPARAM(2) = LEVEC -c No longer referenced. See remark 2 below. -c -c IPARAM(3) = MXITER -c On INPUT: maximum number of Arnoldi update iterations allowed. -c On OUTPUT: actual number of Arnoldi update iterations taken. -c -c IPARAM(4) = NB: blocksize to be used in the recurrence. -c The code currently works only for NB = 1. -c -c IPARAM(5) = NCONV: number of "converged" Ritz values. -c This represents the number of Ritz values that satisfy -c the convergence criterion. -c -c IPARAM(6) = IUPD -c No longer referenced. Implicit restarting is ALWAYS used. -c -c IPARAM(7) = MODE -c On INPUT determines what type of eigenproblem is being solved. -c Must be 1,2,3,4,5; See under \Description of dsaupd for the -c five modes available. -c -c IPARAM(8) = NP -c When ido = 3 and the user provides shifts through reverse -c communication (IPARAM(1)=0), dsaupd returns NP, the number -c of shifts the user is to provide. 0 < NP <=NCV-NEV. See Remark -c 6 below. -c -c IPARAM(9) = NUMOP, IPARAM(10) = NUMOPB, IPARAM(11) = NUMREO, -c OUTPUT: NUMOP = total number of OP*x operations, -c NUMOPB = total number of B*x operations if BMAT='G', -c NUMREO = total number of steps of re-orthogonalization. -c -c IPNTR Integer array of length 11. (OUTPUT) -c Pointer to mark the starting locations in the WORKD and WORKL -c arrays for matrices/vectors used by the Lanczos iteration. -c ------------------------------------------------------------- -c IPNTR(1): pointer to the current operand vector X in WORKD. -c IPNTR(2): pointer to the current result vector Y in WORKD. -c IPNTR(3): pointer to the vector B * X in WORKD when used in -c the shift-and-invert mode. -c IPNTR(4): pointer to the next available location in WORKL -c that is untouched by the program. -c IPNTR(5): pointer to the NCV by 2 tridiagonal matrix T in WORKL. -c IPNTR(6): pointer to the NCV RITZ values array in WORKL. -c IPNTR(7): pointer to the Ritz estimates in array WORKL associated -c with the Ritz values located in RITZ in WORKL. -c IPNTR(11): pointer to the NP shifts in WORKL. See Remark 6 below. -c -c Note: IPNTR(8:10) is only referenced by dseupd . See Remark 2. -c IPNTR(8): pointer to the NCV RITZ values of the original system. -c IPNTR(9): pointer to the NCV corresponding error bounds. -c IPNTR(10): pointer to the NCV by NCV matrix of eigenvectors -c of the tridiagonal matrix T. Only referenced by -c dseupd if RVEC = .TRUE. See Remarks. -c ------------------------------------------------------------- -c -c WORKD Double precision work array of length 3*N. (REVERSE COMMUNICATION) -c Distributed array to be used in the basic Arnoldi iteration -c for reverse communication. The user should not use WORKD -c as temporary workspace during the iteration. Upon termination -c WORKD(1:N) contains B*RESID(1:N). If the Ritz vectors are desired -c subroutine dseupd uses this output. -c See Data Distribution Note below. -c -c WORKL Double precision work array of length LWORKL. (OUTPUT/WORKSPACE) -c Private (replicated) array on each PE or array allocated on -c the front end. See Data Distribution Note below. -c -c LWORKL Integer. (INPUT) -c LWORKL must be at least NCV**2 + 8*NCV . -c -c INFO Integer. (INPUT/OUTPUT) -c If INFO .EQ. 0, a randomly initial residual vector is used. -c If INFO .NE. 0, RESID contains the initial residual vector, -c possibly from a previous run. -c Error flag on output. -c = 0: Normal exit. -c = 1: Maximum number of iterations taken. -c All possible eigenvalues of OP has been found. IPARAM(5) -c returns the number of wanted converged Ritz values. -c = 2: No longer an informational error. Deprecated starting -c with release 2 of ARPACK. -c = 3: No shifts could be applied during a cycle of the -c Implicitly restarted Arnoldi iteration. One possibility -c is to increase the size of NCV relative to NEV. -c See remark 4 below. -c = -1: N must be positive. -c = -2: NEV must be positive. -c = -3: NCV must be greater than NEV and less than or equal to N. -c = -4: The maximum number of Arnoldi update iterations allowed -c must be greater than zero. -c = -5: WHICH must be one of 'LM', 'SM', 'LA', 'SA' or 'BE'. -c = -6: BMAT must be one of 'I' or 'G'. -c = -7: Length of private work array WORKL is not sufficient. -c = -8: Error return from trid. eigenvalue calculation; -c Informatinal error from LAPACK routine dsteqr . -c = -9: Starting vector is zero. -c = -10: IPARAM(7) must be 1,2,3,4,5. -c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatable. -c = -12: IPARAM(1) must be equal to 0 or 1. -c = -13: NEV and WHICH = 'BE' are incompatable. -c = -9999: Could not build an Arnoldi factorization. -c IPARAM(5) returns the size of the current Arnoldi -c factorization. The user is advised to check that -c enough workspace and array storage has been allocated. -c -c -c\Remarks -c 1. The converged Ritz values are always returned in ascending -c algebraic order. The computed Ritz values are approximate -c eigenvalues of OP. The selection of WHICH should be made -c with this in mind when Mode = 3,4,5. After convergence, -c approximate eigenvalues of the original problem may be obtained -c with the ARPACK subroutine dseupd . -c -c 2. If the Ritz vectors corresponding to the converged Ritz values -c are needed, the user must call dseupd immediately following completion -c of dsaupd . This is new starting with version 2.1 of ARPACK. -c -c 3. If M can be factored into a Cholesky factorization M = LL` -c then Mode = 2 should not be selected. Instead one should use -c Mode = 1 with OP = inv(L)*A*inv(L`). Appropriate triangular -c linear systems should be solved with L and L` rather -c than computing inverses. After convergence, an approximate -c eigenvector z of the original problem is recovered by solving -c L`z = x where x is a Ritz vector of OP. -c -c 4. At present there is no a-priori analysis to guide the selection -c of NCV relative to NEV. The only formal requrement is that NCV > NEV. -c However, it is recommended that NCV .ge. 2*NEV. If many problems of -c the same type are to be solved, one should experiment with increasing -c NCV while keeping NEV fixed for a given test problem. This will -c usually decrease the required number of OP*x operations but it -c also increases the work and storage required to maintain the orthogonal -c basis vectors. The optimal "cross-over" with respect to CPU time -c is problem dependent and must be determined empirically. -c -c 5. If IPARAM(7) = 2 then in the Reverse commuication interface the user -c must do the following. When IDO = 1, Y = OP * X is to be computed. -c When IPARAM(7) = 2 OP = inv(B)*A. After computing A*X the user -c must overwrite X with A*X. Y is then the solution to the linear set -c of equations B*Y = A*X. -c -c 6. When IPARAM(1) = 0, and IDO = 3, the user needs to provide the -c NP = IPARAM(8) shifts in locations: -c 1 WORKL(IPNTR(11)) -c 2 WORKL(IPNTR(11)+1) -c . -c . -c . -c NP WORKL(IPNTR(11)+NP-1). -c -c The eigenvalues of the current tridiagonal matrix are located in -c WORKL(IPNTR(6)) through WORKL(IPNTR(6)+NCV-1). They are in the -c order defined by WHICH. The associated Ritz estimates are located in -c WORKL(IPNTR(8)), WORKL(IPNTR(8)+1), ... , WORKL(IPNTR(8)+NCV-1). -c -c----------------------------------------------------------------------- -c -c\Data Distribution Note: -c -c Fortran-D syntax: -c ================ -c REAL RESID(N), V(LDV,NCV), WORKD(3*N), WORKL(LWORKL) -c DECOMPOSE D1(N), D2(N,NCV) -c ALIGN RESID(I) with D1(I) -c ALIGN V(I,J) with D2(I,J) -c ALIGN WORKD(I) with D1(I) range (1:N) -c ALIGN WORKD(I) with D1(I-N) range (N+1:2*N) -c ALIGN WORKD(I) with D1(I-2*N) range (2*N+1:3*N) -c DISTRIBUTE D1(BLOCK), D2(BLOCK,:) -c REPLICATED WORKL(LWORKL) -c -c Cray MPP syntax: -c =============== -c REAL RESID(N), V(LDV,NCV), WORKD(N,3), WORKL(LWORKL) -c SHARED RESID(BLOCK), V(BLOCK,:), WORKD(BLOCK,:) -c REPLICATED WORKL(LWORKL) -c -c -c\BeginLib -c -c\References: -c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in -c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), -c pp 357-385. -c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly -c Restarted Arnoldi Iteration", Rice University Technical Report -c TR95-13, Department of Computational and Applied Mathematics. -c 3. B.N. Parlett, "The Symmetric Eigenvalue Problem". Prentice-Hall, -c 1980. -c 4. B.N. Parlett, B. Nour-Omid, "Towards a Black Box Lanczos Program", -c Computer Physics Communications, 53 (1989), pp 169-179. -c 5. B. Nour-Omid, B.N. Parlett, T. Ericson, P.S. Jensen, "How to -c Implement the Spectral Transformation", Math. Comp., 48 (1987), -c pp 663-673. -c 6. R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos -c Algorithm for Solving Sparse Symmetric Generalized Eigenproblems", -c SIAM J. Matr. Anal. Apps., January (1993). -c 7. L. Reichel, W.B. Gragg, "Algorithm 686: FORTRAN Subroutines -c for Updating the QR decomposition", ACM TOMS, December 1990, -c Volume 16 Number 4, pp 369-377. -c 8. R.B. Lehoucq, D.C. Sorensen, "Implementation of Some Spectral -c Transformations in a k-Step Arnoldi Method". In Preparation. -c -c\Routines called: -c dsaup2 ARPACK routine that implements the Implicitly Restarted -c Arnoldi Iteration. -c dstats ARPACK routine that initialize timing and other statistics -c variables. -c ivout ARPACK utility routine that prints integers. -c arscnd ARPACK utility routine for timing. -c dvout ARPACK utility routine that prints vectors. -c dlamch LAPACK routine that determines machine constants. -c -c\Authors -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\Revision history: -c 12/15/93: Version ' 2.4' -c -c\SCCS Information: @(#) -c FILE: saupd.F SID: 2.8 DATE OF SID: 04/10/01 RELEASE: 2 -c -c\Remarks -c 1. None -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine dsaupd - & ( ido, bmat, n, which, nev, tol, resid, ncv, v, ldv, iparam, - & ipntr, workd, workl, lworkl, info ) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - character bmat*1, which*2 - integer ido, info, ldv, lworkl, n, ncv, nev - Double precision - & tol -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - integer iparam(11), ipntr(11) - Double precision - & resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) -c -c %------------% -c | Parameters | -c %------------% -c - Double precision - & one, zero - parameter (one = 1.0D+0 , zero = 0.0D+0 ) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - integer bounds, ierr, ih, iq, ishift, iupd, iw, - & ldh, ldq, msglvl, mxiter, mode, nb, - & nev0, next, np, ritz, j - save bounds, ierr, ih, iq, ishift, iupd, iw, - & ldh, ldq, msglvl, mxiter, mode, nb, - & nev0, next, np, ritz -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external dsaup2 , dvout , ivout, arscnd, dstats -c -c %--------------------% -c | External Functions | -c %--------------------% -c - Double precision - & dlamch - external dlamch -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c - if (ido .eq. 0) then -c -c %-------------------------------% -c | Initialize timing statistics | -c | & message level for debugging | -c %-------------------------------% -c - call dstats - call arscnd (t0) - msglvl = msaupd -c - ierr = 0 - ishift = iparam(1) - mxiter = iparam(3) -c nb = iparam(4) - nb = 1 -c -c %--------------------------------------------% -c | Revision 2 performs only implicit restart. | -c %--------------------------------------------% -c - iupd = 1 - mode = iparam(7) -c -c %----------------% -c | Error checking | -c %----------------% -c - if (n .le. 0) then - ierr = -1 - else if (nev .le. 0) then - ierr = -2 - else if (ncv .le. nev .or. ncv .gt. n) then - ierr = -3 - end if -c -c %----------------------------------------------% -c | NP is the number of additional steps to | -c | extend the length NEV Lanczos factorization. | -c %----------------------------------------------% -c - np = ncv - nev -c - if (mxiter .le. 0) ierr = -4 - if (which .ne. 'LM' .and. - & which .ne. 'SM' .and. - & which .ne. 'LA' .and. - & which .ne. 'SA' .and. - & which .ne. 'BE') ierr = -5 - if (bmat .ne. 'I' .and. bmat .ne. 'G') ierr = -6 -c - if (lworkl .lt. ncv**2 + 8*ncv) ierr = -7 - if (mode .lt. 1 .or. mode .gt. 5) then - ierr = -10 - else if (mode .eq. 1 .and. bmat .eq. 'G') then - ierr = -11 - else if (ishift .lt. 0 .or. ishift .gt. 1) then - ierr = -12 - else if (nev .eq. 1 .and. which .eq. 'BE') then - ierr = -13 - end if -c -c %------------% -c | Error Exit | -c %------------% -c - if (ierr .ne. 0) then - info = ierr - ido = 99 - go to 9000 - end if -c -c %------------------------% -c | Set default parameters | -c %------------------------% -c - if (nb .le. 0) nb = 1 - if (tol .le. zero) tol = dlamch ('EpsMach') -c -c %----------------------------------------------% -c | NP is the number of additional steps to | -c | extend the length NEV Lanczos factorization. | -c | NEV0 is the local variable designating the | -c | size of the invariant subspace desired. | -c %----------------------------------------------% -c - np = ncv - nev - nev0 = nev -c -c %-----------------------------% -c | Zero out internal workspace | -c %-----------------------------% -c - do 10 j = 1, ncv**2 + 8*ncv - workl(j) = zero - 10 continue -c -c %-------------------------------------------------------% -c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | -c | etc... and the remaining workspace. | -c | Also update pointer to be used on output. | -c | Memory is laid out as follows: | -c | workl(1:2*ncv) := generated tridiagonal matrix | -c | workl(2*ncv+1:2*ncv+ncv) := ritz values | -c | workl(3*ncv+1:3*ncv+ncv) := computed error bounds | -c | workl(4*ncv+1:4*ncv+ncv*ncv) := rotation matrix Q | -c | workl(4*ncv+ncv*ncv+1:7*ncv+ncv*ncv) := workspace | -c %-------------------------------------------------------% -c - ldh = ncv - ldq = ncv - ih = 1 - ritz = ih + 2*ldh - bounds = ritz + ncv - iq = bounds + ncv - iw = iq + ncv**2 - next = iw + 3*ncv -c - ipntr(4) = next - ipntr(5) = ih - ipntr(6) = ritz - ipntr(7) = bounds - ipntr(11) = iw - end if -c -c %-------------------------------------------------------% -c | Carry out the Implicitly restarted Lanczos Iteration. | -c %-------------------------------------------------------% -c - call dsaup2 - & ( ido, bmat, n, which, nev0, np, tol, resid, mode, iupd, - & ishift, mxiter, v, ldv, workl(ih), ldh, workl(ritz), - & workl(bounds), workl(iq), ldq, workl(iw), ipntr, workd, - & info ) -c -c %--------------------------------------------------% -c | ido .ne. 99 implies use of reverse communication | -c | to compute operations involving OP or shifts. | -c %--------------------------------------------------% -c - if (ido .eq. 3) iparam(8) = np - if (ido .ne. 99) go to 9000 -c - iparam(3) = mxiter - iparam(5) = np - iparam(9) = nopx - iparam(10) = nbx - iparam(11) = nrorth -c -c %------------------------------------% -c | Exit if there was an informational | -c | error within dsaup2 . | -c %------------------------------------% -c - if (info .lt. 0) go to 9000 - if (info .eq. 2) info = 3 -c - if (msglvl .gt. 0) then - call ivout (logfil, 1, mxiter, ndigit, - & '_saupd: number of update iterations taken') - call ivout (logfil, 1, np, ndigit, - & '_saupd: number of "converged" Ritz values') - call dvout (logfil, np, workl(Ritz), ndigit, - & '_saupd: final Ritz values') - call dvout (logfil, np, workl(Bounds), ndigit, - & '_saupd: corresponding error bounds') - end if -c - call arscnd (t1) - tsaupd = t1 - t0 -c - if (msglvl .gt. 0) then -c -c %--------------------------------------------------------% -c | Version Number & Version Date are defined in version.h | -c %--------------------------------------------------------% -c - write (6,1000) - write (6,1100) mxiter, nopx, nbx, nrorth, nitref, nrstrt, - & tmvopx, tmvbx, tsaupd, tsaup2, tsaitr, titref, - & tgetv0, tseigt, tsgets, tsapps, tsconv - 1000 format (//, - & 5x, '==========================================',/ - & 5x, '= Symmetric implicit Arnoldi update code =',/ - & 5x, '= Version Number:', ' 2.4' , 19x, ' =',/ - & 5x, '= Version Date: ', ' 07/31/96' , 14x, ' =',/ - & 5x, '==========================================',/ - & 5x, '= Summary of timing statistics =',/ - & 5x, '==========================================',//) - 1100 format ( - & 5x, 'Total number update iterations = ', i5,/ - & 5x, 'Total number of OP*x operations = ', i5,/ - & 5x, 'Total number of B*x operations = ', i5,/ - & 5x, 'Total number of reorthogonalization steps = ', i5,/ - & 5x, 'Total number of iterative refinement steps = ', i5,/ - & 5x, 'Total number of restart steps = ', i5,/ - & 5x, 'Total time in user OP*x operation = ', f12.6,/ - & 5x, 'Total time in user B*x operation = ', f12.6,/ - & 5x, 'Total time in Arnoldi update routine = ', f12.6,/ - & 5x, 'Total time in saup2 routine = ', f12.6,/ - & 5x, 'Total time in basic Arnoldi iteration loop = ', f12.6,/ - & 5x, 'Total time in reorthogonalization phase = ', f12.6,/ - & 5x, 'Total time in (re)start vector generation = ', f12.6,/ - & 5x, 'Total time in trid eigenvalue subproblem = ', f12.6,/ - & 5x, 'Total time in getting the shifts = ', f12.6,/ - & 5x, 'Total time in applying the shifts = ', f12.6,/ - & 5x, 'Total time in convergence testing = ', f12.6) - end if -c - 9000 continue -c - return -c -c %---------------% -c | End of dsaupd | -c %---------------% -c - end
--- a/libcruft/arpack/src/dsconv.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,138 +0,0 @@ -c----------------------------------------------------------------------- -c\BeginDoc -c -c\Name: dsconv -c -c\Description: -c Convergence testing for the symmetric Arnoldi eigenvalue routine. -c -c\Usage: -c call dsconv -c ( N, RITZ, BOUNDS, TOL, NCONV ) -c -c\Arguments -c N Integer. (INPUT) -c Number of Ritz values to check for convergence. -c -c RITZ Double precision array of length N. (INPUT) -c The Ritz values to be checked for convergence. -c -c BOUNDS Double precision array of length N. (INPUT) -c Ritz estimates associated with the Ritz values in RITZ. -c -c TOL Double precision scalar. (INPUT) -c Desired relative accuracy for a Ritz value to be considered -c "converged". -c -c NCONV Integer scalar. (OUTPUT) -c Number of "converged" Ritz values. -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Routines called: -c arscnd ARPACK utility routine for timing. -c dlamch LAPACK routine that determines machine constants. -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\SCCS Information: @(#) -c FILE: sconv.F SID: 2.4 DATE OF SID: 4/19/96 RELEASE: 2 -c -c\Remarks -c 1. Starting with version 2.4, this routine no longer uses the -c Parlett strategy using the gap conditions. -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine dsconv (n, ritz, bounds, tol, nconv) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - integer n, nconv - Double precision - & tol -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - Double precision - & ritz(n), bounds(n) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - integer i - Double precision - & temp, eps23 -c -c %-------------------% -c | External routines | -c %-------------------% -c - Double precision - & dlamch - external dlamch - -c %---------------------% -c | Intrinsic Functions | -c %---------------------% -c - intrinsic abs -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c - call arscnd (t0) -c - eps23 = dlamch('Epsilon-Machine') - eps23 = eps23**(2.0D+0 / 3.0D+0) -c - nconv = 0 - do 10 i = 1, n -c -c %-----------------------------------------------------% -c | The i-th Ritz value is considered "converged" | -c | when: bounds(i) .le. TOL*max(eps23, abs(ritz(i))) | -c %-----------------------------------------------------% -c - temp = max( eps23, abs(ritz(i)) ) - if ( bounds(i) .le. tol*temp ) then - nconv = nconv + 1 - end if -c - 10 continue -c - call arscnd (t1) - tsconv = tsconv + (t1 - t0) -c - return -c -c %---------------% -c | End of dsconv | -c %---------------% -c - end
--- a/libcruft/arpack/src/dseigt.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,181 +0,0 @@ -c----------------------------------------------------------------------- -c\BeginDoc -c -c\Name: dseigt -c -c\Description: -c Compute the eigenvalues of the current symmetric tridiagonal matrix -c and the corresponding error bounds given the current residual norm. -c -c\Usage: -c call dseigt -c ( RNORM, N, H, LDH, EIG, BOUNDS, WORKL, IERR ) -c -c\Arguments -c RNORM Double precision scalar. (INPUT) -c RNORM contains the residual norm corresponding to the current -c symmetric tridiagonal matrix H. -c -c N Integer. (INPUT) -c Size of the symmetric tridiagonal matrix H. -c -c H Double precision N by 2 array. (INPUT) -c H contains the symmetric tridiagonal matrix with the -c subdiagonal in the first column starting at H(2,1) and the -c main diagonal in second column. -c -c LDH Integer. (INPUT) -c Leading dimension of H exactly as declared in the calling -c program. -c -c EIG Double precision array of length N. (OUTPUT) -c On output, EIG contains the N eigenvalues of H possibly -c unsorted. The BOUNDS arrays are returned in the -c same sorted order as EIG. -c -c BOUNDS Double precision array of length N. (OUTPUT) -c On output, BOUNDS contains the error estimates corresponding -c to the eigenvalues EIG. This is equal to RNORM times the -c last components of the eigenvectors corresponding to the -c eigenvalues in EIG. -c -c WORKL Double precision work array of length 3*N. (WORKSPACE) -c Private (replicated) array on each PE or array allocated on -c the front end. -c -c IERR Integer. (OUTPUT) -c Error exit flag from dstqrb. -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Local variables: -c xxxxxx real -c -c\Routines called: -c dstqrb ARPACK routine that computes the eigenvalues and the -c last components of the eigenvectors of a symmetric -c and tridiagonal matrix. -c arscnd ARPACK utility routine for timing. -c dvout ARPACK utility routine that prints vectors. -c dcopy Level 1 BLAS that copies one vector to another. -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\Revision history: -c xx/xx/92: Version ' 2.4' -c -c\SCCS Information: @(#) -c FILE: seigt.F SID: 2.4 DATE OF SID: 8/27/96 RELEASE: 2 -c -c\Remarks -c None -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine dseigt - & ( rnorm, n, h, ldh, eig, bounds, workl, ierr ) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - integer ierr, ldh, n - Double precision - & rnorm -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - Double precision - & eig(n), bounds(n), h(ldh,2), workl(3*n) -c -c %------------% -c | Parameters | -c %------------% -c - Double precision - & zero - parameter (zero = 0.0D+0) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - integer i, k, msglvl -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external dcopy, dstqrb, dvout, arscnd -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c -c %-------------------------------% -c | Initialize timing statistics | -c | & message level for debugging | -c %-------------------------------% -c - call arscnd (t0) - msglvl = mseigt -c - if (msglvl .gt. 0) then - call dvout (logfil, n, h(1,2), ndigit, - & '_seigt: main diagonal of matrix H') - if (n .gt. 1) then - call dvout (logfil, n-1, h(2,1), ndigit, - & '_seigt: sub diagonal of matrix H') - end if - end if -c - call dcopy (n, h(1,2), 1, eig, 1) - call dcopy (n-1, h(2,1), 1, workl, 1) - call dstqrb (n, eig, workl, bounds, workl(n+1), ierr) - if (ierr .ne. 0) go to 9000 - if (msglvl .gt. 1) then - call dvout (logfil, n, bounds, ndigit, - & '_seigt: last row of the eigenvector matrix for H') - end if -c -c %-----------------------------------------------% -c | Finally determine the error bounds associated | -c | with the n Ritz values of H. | -c %-----------------------------------------------% -c - do 30 k = 1, n - bounds(k) = rnorm*abs(bounds(k)) - 30 continue -c - call arscnd (t1) - tseigt = tseigt + (t1 - t0) -c - 9000 continue - return -c -c %---------------% -c | End of dseigt | -c %---------------% -c - end
--- a/libcruft/arpack/src/dsesrt.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,217 +0,0 @@ -c----------------------------------------------------------------------- -c\BeginDoc -c -c\Name: dsesrt -c -c\Description: -c Sort the array X in the order specified by WHICH and optionally -c apply the permutation to the columns of the matrix A. -c -c\Usage: -c call dsesrt -c ( WHICH, APPLY, N, X, NA, A, LDA) -c -c\Arguments -c WHICH Character*2. (Input) -c 'LM' -> X is sorted into increasing order of magnitude. -c 'SM' -> X is sorted into decreasing order of magnitude. -c 'LA' -> X is sorted into increasing order of algebraic. -c 'SA' -> X is sorted into decreasing order of algebraic. -c -c APPLY Logical. (Input) -c APPLY = .TRUE. -> apply the sorted order to A. -c APPLY = .FALSE. -> do not apply the sorted order to A. -c -c N Integer. (INPUT) -c Dimension of the array X. -c -c X Double precision array of length N. (INPUT/OUTPUT) -c The array to be sorted. -c -c NA Integer. (INPUT) -c Number of rows of the matrix A. -c -c A Double precision array of length NA by N. (INPUT/OUTPUT) -c -c LDA Integer. (INPUT) -c Leading dimension of A. -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Routines -c dswap Level 1 BLAS that swaps the contents of two vectors. -c -c\Authors -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\Revision history: -c 12/15/93: Version ' 2.1'. -c Adapted from the sort routine in LANSO and -c the ARPACK code dsortr -c -c\SCCS Information: @(#) -c FILE: sesrt.F SID: 2.3 DATE OF SID: 4/19/96 RELEASE: 2 -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine dsesrt (which, apply, n, x, na, a, lda) -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - character*2 which - logical apply - integer lda, n, na -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - Double precision - & x(0:n-1), a(lda, 0:n-1) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - integer i, igap, j - Double precision - & temp -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external dswap -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c - igap = n / 2 -c - if (which .eq. 'SA') then -c -c X is sorted into decreasing order of algebraic. -c - 10 continue - if (igap .eq. 0) go to 9000 - do 30 i = igap, n-1 - j = i-igap - 20 continue -c - if (j.lt.0) go to 30 -c - if (x(j).lt.x(j+igap)) then - temp = x(j) - x(j) = x(j+igap) - x(j+igap) = temp - if (apply) call dswap( na, a(1, j), 1, a(1,j+igap), 1) - else - go to 30 - endif - j = j-igap - go to 20 - 30 continue - igap = igap / 2 - go to 10 -c - else if (which .eq. 'SM') then -c -c X is sorted into decreasing order of magnitude. -c - 40 continue - if (igap .eq. 0) go to 9000 - do 60 i = igap, n-1 - j = i-igap - 50 continue -c - if (j.lt.0) go to 60 -c - if (abs(x(j)).lt.abs(x(j+igap))) then - temp = x(j) - x(j) = x(j+igap) - x(j+igap) = temp - if (apply) call dswap( na, a(1, j), 1, a(1,j+igap), 1) - else - go to 60 - endif - j = j-igap - go to 50 - 60 continue - igap = igap / 2 - go to 40 -c - else if (which .eq. 'LA') then -c -c X is sorted into increasing order of algebraic. -c - 70 continue - if (igap .eq. 0) go to 9000 - do 90 i = igap, n-1 - j = i-igap - 80 continue -c - if (j.lt.0) go to 90 -c - if (x(j).gt.x(j+igap)) then - temp = x(j) - x(j) = x(j+igap) - x(j+igap) = temp - if (apply) call dswap( na, a(1, j), 1, a(1,j+igap), 1) - else - go to 90 - endif - j = j-igap - go to 80 - 90 continue - igap = igap / 2 - go to 70 -c - else if (which .eq. 'LM') then -c -c X is sorted into increasing order of magnitude. -c - 100 continue - if (igap .eq. 0) go to 9000 - do 120 i = igap, n-1 - j = i-igap - 110 continue -c - if (j.lt.0) go to 120 -c - if (abs(x(j)).gt.abs(x(j+igap))) then - temp = x(j) - x(j) = x(j+igap) - x(j+igap) = temp - if (apply) call dswap( na, a(1, j), 1, a(1,j+igap), 1) - else - go to 120 - endif - j = j-igap - go to 110 - 120 continue - igap = igap / 2 - go to 100 - end if -c - 9000 continue - return -c -c %---------------% -c | End of dsesrt | -c %---------------% -c - end
--- a/libcruft/arpack/src/dseupd.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,857 +0,0 @@ -c\BeginDoc -c -c\Name: dseupd -c -c\Description: -c -c This subroutine returns the converged approximations to eigenvalues -c of A*z = lambda*B*z and (optionally): -c -c (1) the corresponding approximate eigenvectors, -c -c (2) an orthonormal (Lanczos) basis for the associated approximate -c invariant subspace, -c -c (3) Both. -c -c There is negligible additional cost to obtain eigenvectors. An orthonormal -c (Lanczos) basis is always computed. There is an additional storage cost -c of n*nev if both are requested (in this case a separate array Z must be -c supplied). -c -c These quantities are obtained from the Lanczos factorization computed -c by DSAUPD for the linear operator OP prescribed by the MODE selection -c (see IPARAM(7) in DSAUPD documentation.) DSAUPD must be called before -c this routine is called. These approximate eigenvalues and vectors are -c commonly called Ritz values and Ritz vectors respectively. They are -c referred to as such in the comments that follow. The computed orthonormal -c basis for the invariant subspace corresponding to these Ritz values is -c referred to as a Lanczos basis. -c -c See documentation in the header of the subroutine DSAUPD for a definition -c of OP as well as other terms and the relation of computed Ritz values -c and vectors of OP with respect to the given problem A*z = lambda*B*z. -c -c The approximate eigenvalues of the original problem are returned in -c ascending algebraic order. The user may elect to call this routine -c once for each desired Ritz vector and store it peripherally if desired. -c There is also the option of computing a selected set of these vectors -c with a single call. -c -c\Usage: -c call dseupd -c ( RVEC, HOWMNY, SELECT, D, Z, LDZ, SIGMA, BMAT, N, WHICH, NEV, TOL, -c RESID, NCV, V, LDV, IPARAM, IPNTR, WORKD, WORKL, LWORKL, INFO ) -c -c RVEC LOGICAL (INPUT) -c Specifies whether Ritz vectors corresponding to the Ritz value -c approximations to the eigenproblem A*z = lambda*B*z are computed. -c -c RVEC = .FALSE. Compute Ritz values only. -c -c RVEC = .TRUE. Compute Ritz vectors. -c -c HOWMNY Character*1 (INPUT) -c Specifies how many Ritz vectors are wanted and the form of Z -c the matrix of Ritz vectors. See remark 1 below. -c = 'A': compute NEV Ritz vectors; -c = 'S': compute some of the Ritz vectors, specified -c by the logical array SELECT. -c -c SELECT Logical array of dimension NCV. (INPUT/WORKSPACE) -c If HOWMNY = 'S', SELECT specifies the Ritz vectors to be -c computed. To select the Ritz vector corresponding to a -c Ritz value D(j), SELECT(j) must be set to .TRUE.. -c If HOWMNY = 'A' , SELECT is used as a workspace for -c reordering the Ritz values. -c -c D Double precision array of dimension NEV. (OUTPUT) -c On exit, D contains the Ritz value approximations to the -c eigenvalues of A*z = lambda*B*z. The values are returned -c in ascending order. If IPARAM(7) = 3,4,5 then D represents -c the Ritz values of OP computed by dsaupd transformed to -c those of the original eigensystem A*z = lambda*B*z. If -c IPARAM(7) = 1,2 then the Ritz values of OP are the same -c as the those of A*z = lambda*B*z. -c -c Z Double precision N by NEV array if HOWMNY = 'A'. (OUTPUT) -c On exit, Z contains the B-orthonormal Ritz vectors of the -c eigensystem A*z = lambda*B*z corresponding to the Ritz -c value approximations. -c If RVEC = .FALSE. then Z is not referenced. -c NOTE: The array Z may be set equal to first NEV columns of the -c Arnoldi/Lanczos basis array V computed by DSAUPD . -c -c LDZ Integer. (INPUT) -c The leading dimension of the array Z. If Ritz vectors are -c desired, then LDZ .ge. max( 1, N ). In any case, LDZ .ge. 1. -c -c SIGMA Double precision (INPUT) -c If IPARAM(7) = 3,4,5 represents the shift. Not referenced if -c IPARAM(7) = 1 or 2. -c -c -c **** The remaining arguments MUST be the same as for the **** -c **** call to DSAUPD that was just completed. **** -c -c NOTE: The remaining arguments -c -c BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, -c WORKD, WORKL, LWORKL, INFO -c -c must be passed directly to DSEUPD following the last call -c to DSAUPD . These arguments MUST NOT BE MODIFIED between -c the the last call to DSAUPD and the call to DSEUPD . -c -c Two of these parameters (WORKL, INFO) are also output parameters: -c -c WORKL Double precision work array of length LWORKL. (OUTPUT/WORKSPACE) -c WORKL(1:4*ncv) contains information obtained in -c dsaupd . They are not changed by dseupd . -c WORKL(4*ncv+1:ncv*ncv+8*ncv) holds the -c untransformed Ritz values, the computed error estimates, -c and the associated eigenvector matrix of H. -c -c Note: IPNTR(8:10) contains the pointer into WORKL for addresses -c of the above information computed by dseupd . -c ------------------------------------------------------------- -c IPNTR(8): pointer to the NCV RITZ values of the original system. -c IPNTR(9): pointer to the NCV corresponding error bounds. -c IPNTR(10): pointer to the NCV by NCV matrix of eigenvectors -c of the tridiagonal matrix T. Only referenced by -c dseupd if RVEC = .TRUE. See Remarks. -c ------------------------------------------------------------- -c -c INFO Integer. (OUTPUT) -c Error flag on output. -c = 0: Normal exit. -c = -1: N must be positive. -c = -2: NEV must be positive. -c = -3: NCV must be greater than NEV and less than or equal to N. -c = -5: WHICH must be one of 'LM', 'SM', 'LA', 'SA' or 'BE'. -c = -6: BMAT must be one of 'I' or 'G'. -c = -7: Length of private work WORKL array is not sufficient. -c = -8: Error return from trid. eigenvalue calculation; -c Information error from LAPACK routine dsteqr . -c = -9: Starting vector is zero. -c = -10: IPARAM(7) must be 1,2,3,4,5. -c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. -c = -12: NEV and WHICH = 'BE' are incompatible. -c = -14: DSAUPD did not find any eigenvalues to sufficient -c accuracy. -c = -15: HOWMNY must be one of 'A' or 'S' if RVEC = .true. -c = -16: HOWMNY = 'S' not yet implemented -c = -17: DSEUPD got a different count of the number of converged -c Ritz values than DSAUPD got. This indicates the user -c probably made an error in passing data from DSAUPD to -c DSEUPD or that the data was modified before entering -c DSEUPD . -c -c\BeginLib -c -c\References: -c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in -c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), -c pp 357-385. -c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly -c Restarted Arnoldi Iteration", Rice University Technical Report -c TR95-13, Department of Computational and Applied Mathematics. -c 3. B.N. Parlett, "The Symmetric Eigenvalue Problem". Prentice-Hall, -c 1980. -c 4. B.N. Parlett, B. Nour-Omid, "Towards a Black Box Lanczos Program", -c Computer Physics Communications, 53 (1989), pp 169-179. -c 5. B. Nour-Omid, B.N. Parlett, T. Ericson, P.S. Jensen, "How to -c Implement the Spectral Transformation", Math. Comp., 48 (1987), -c pp 663-673. -c 6. R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos -c Algorithm for Solving Sparse Symmetric Generalized Eigenproblems", -c SIAM J. Matr. Anal. Apps., January (1993). -c 7. L. Reichel, W.B. Gragg, "Algorithm 686: FORTRAN Subroutines -c for Updating the QR decomposition", ACM TOMS, December 1990, -c Volume 16 Number 4, pp 369-377. -c -c\Remarks -c 1. The converged Ritz values are always returned in increasing -c (algebraic) order. -c -c 2. Currently only HOWMNY = 'A' is implemented. It is included at this -c stage for the user who wants to incorporate it. -c -c\Routines called: -c dsesrt ARPACK routine that sorts an array X, and applies the -c corresponding permutation to a matrix A. -c dsortr dsortr ARPACK sorting routine. -c ivout ARPACK utility routine that prints integers. -c dvout ARPACK utility routine that prints vectors. -c dgeqr2 LAPACK routine that computes the QR factorization of -c a matrix. -c dlacpy LAPACK matrix copy routine. -c dlamch LAPACK routine that determines machine constants. -c dorm2r LAPACK routine that applies an orthogonal matrix in -c factored form. -c dsteqr LAPACK routine that computes eigenvalues and eigenvectors -c of a tridiagonal matrix. -c dger Level 2 BLAS rank one update to a matrix. -c dcopy Level 1 BLAS that copies one vector to another . -c dnrm2 Level 1 BLAS that computes the norm of a vector. -c dscal Level 1 BLAS that scales a vector. -c dswap Level 1 BLAS that swaps the contents of two vectors. - -c\Authors -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Chao Yang Houston, Texas -c Dept. of Computational & -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\Revision history: -c 12/15/93: Version ' 2.1' -c -c\SCCS Information: @(#) -c FILE: seupd.F SID: 2.11 DATE OF SID: 04/10/01 RELEASE: 2 -c -c\EndLib -c -c----------------------------------------------------------------------- - subroutine dseupd (rvec , howmny, select, d , - & z , ldz , sigma , bmat , - & n , which , nev , tol , - & resid , ncv , v , ldv , - & iparam, ipntr , workd , workl, - & lworkl, info ) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - character bmat, howmny, which*2 - logical rvec - integer info, ldz, ldv, lworkl, n, ncv, nev - Double precision - & sigma, tol -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - integer iparam(7), ipntr(11) - logical select(ncv) - Double precision - & d(nev) , resid(n) , v(ldv,ncv), - & z(ldz, nev), workd(2*n), workl(lworkl) -c -c %------------% -c | Parameters | -c %------------% -c - Double precision - & one, zero - parameter (one = 1.0D+0 , zero = 0.0D+0 ) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - character type*6 - integer bounds , ierr , ih , ihb , ihd , - & iq , iw , j , k , ldh , - & ldq , mode , msglvl, nconv , next , - & ritz , irz , ibd , np , ishift, - & leftptr, rghtptr, numcnv, jj - Double precision - & bnorm2 , rnorm, temp, temp1, eps23 - logical reord -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external dcopy , dger , dgeqr2 , dlacpy , dorm2r , dscal , - & dsesrt , dsteqr , dswap , dvout , ivout , dsortr -c -c %--------------------% -c | External Functions | -c %--------------------% -c - Double precision - & dnrm2 , dlamch - external dnrm2 , dlamch -c -c %---------------------% -c | Intrinsic Functions | -c %---------------------% -c - intrinsic min -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c -c %------------------------% -c | Set default parameters | -c %------------------------% -c - msglvl = mseupd - mode = iparam(7) - nconv = iparam(5) - info = 0 -c -c %--------------% -c | Quick return | -c %--------------% -c - if (nconv .eq. 0) go to 9000 - ierr = 0 -c - if (nconv .le. 0) ierr = -14 - if (n .le. 0) ierr = -1 - if (nev .le. 0) ierr = -2 - if (ncv .le. nev .or. ncv .gt. n) ierr = -3 - if (which .ne. 'LM' .and. - & which .ne. 'SM' .and. - & which .ne. 'LA' .and. - & which .ne. 'SA' .and. - & which .ne. 'BE') ierr = -5 - if (bmat .ne. 'I' .and. bmat .ne. 'G') ierr = -6 - if ( (howmny .ne. 'A' .and. - & howmny .ne. 'P' .and. - & howmny .ne. 'S') .and. rvec ) - & ierr = -15 - if (rvec .and. howmny .eq. 'S') ierr = -16 -c - if (rvec .and. lworkl .lt. ncv**2+8*ncv) ierr = -7 -c - if (mode .eq. 1 .or. mode .eq. 2) then - type = 'REGULR' - else if (mode .eq. 3 ) then - type = 'SHIFTI' - else if (mode .eq. 4 ) then - type = 'BUCKLE' - else if (mode .eq. 5 ) then - type = 'CAYLEY' - else - ierr = -10 - end if - if (mode .eq. 1 .and. bmat .eq. 'G') ierr = -11 - if (nev .eq. 1 .and. which .eq. 'BE') ierr = -12 -c -c %------------% -c | Error Exit | -c %------------% -c - if (ierr .ne. 0) then - info = ierr - go to 9000 - end if -c -c %-------------------------------------------------------% -c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | -c | etc... and the remaining workspace. | -c | Also update pointer to be used on output. | -c | Memory is laid out as follows: | -c | workl(1:2*ncv) := generated tridiagonal matrix H | -c | The subdiagonal is stored in workl(2:ncv). | -c | The dead spot is workl(1) but upon exiting | -c | dsaupd stores the B-norm of the last residual | -c | vector in workl(1). We use this !!! | -c | workl(2*ncv+1:2*ncv+ncv) := ritz values | -c | The wanted values are in the first NCONV spots. | -c | workl(3*ncv+1:3*ncv+ncv) := computed Ritz estimates | -c | The wanted values are in the first NCONV spots. | -c | NOTE: workl(1:4*ncv) is set by dsaupd and is not | -c | modified by dseupd . | -c %-------------------------------------------------------% -c -c %-------------------------------------------------------% -c | The following is used and set by dseupd . | -c | workl(4*ncv+1:4*ncv+ncv) := used as workspace during | -c | computation of the eigenvectors of H. Stores | -c | the diagonal of H. Upon EXIT contains the NCV | -c | Ritz values of the original system. The first | -c | NCONV spots have the wanted values. If MODE = | -c | 1 or 2 then will equal workl(2*ncv+1:3*ncv). | -c | workl(5*ncv+1:5*ncv+ncv) := used as workspace during | -c | computation of the eigenvectors of H. Stores | -c | the subdiagonal of H. Upon EXIT contains the | -c | NCV corresponding Ritz estimates of the | -c | original system. The first NCONV spots have the | -c | wanted values. If MODE = 1,2 then will equal | -c | workl(3*ncv+1:4*ncv). | -c | workl(6*ncv+1:6*ncv+ncv*ncv) := orthogonal Q that is | -c | the eigenvector matrix for H as returned by | -c | dsteqr . Not referenced if RVEC = .False. | -c | Ordering follows that of workl(4*ncv+1:5*ncv) | -c | workl(6*ncv+ncv*ncv+1:6*ncv+ncv*ncv+2*ncv) := | -c | Workspace. Needed by dsteqr and by dseupd . | -c | GRAND total of NCV*(NCV+8) locations. | -c %-------------------------------------------------------% -c -c - ih = ipntr(5) - ritz = ipntr(6) - bounds = ipntr(7) - ldh = ncv - ldq = ncv - ihd = bounds + ldh - ihb = ihd + ldh - iq = ihb + ldh - iw = iq + ldh*ncv - next = iw + 2*ncv - ipntr(4) = next - ipntr(8) = ihd - ipntr(9) = ihb - ipntr(10) = iq -c -c %----------------------------------------% -c | irz points to the Ritz values computed | -c | by _seigt before exiting _saup2. | -c | ibd points to the Ritz estimates | -c | computed by _seigt before exiting | -c | _saup2. | -c %----------------------------------------% -c - irz = ipntr(11)+ncv - ibd = irz+ncv -c -c -c %---------------------------------% -c | Set machine dependent constant. | -c %---------------------------------% -c - eps23 = dlamch ('Epsilon-Machine') - eps23 = eps23**(2.0D+0 / 3.0D+0 ) -c -c %---------------------------------------% -c | RNORM is B-norm of the RESID(1:N). | -c | BNORM2 is the 2 norm of B*RESID(1:N). | -c | Upon exit of dsaupd WORKD(1:N) has | -c | B*RESID(1:N). | -c %---------------------------------------% -c - rnorm = workl(ih) - if (bmat .eq. 'I') then - bnorm2 = rnorm - else if (bmat .eq. 'G') then - bnorm2 = dnrm2 (n, workd, 1) - end if -c - if (msglvl .gt. 2) then - call dvout (logfil, ncv, workl(irz), ndigit, - & '_seupd: Ritz values passed in from _SAUPD.') - call dvout (logfil, ncv, workl(ibd), ndigit, - & '_seupd: Ritz estimates passed in from _SAUPD.') - end if -c - if (rvec) then -c - reord = .false. -c -c %---------------------------------------------------% -c | Use the temporary bounds array to store indices | -c | These will be used to mark the select array later | -c %---------------------------------------------------% -c - do 10 j = 1,ncv - workl(bounds+j-1) = j - select(j) = .false. - 10 continue -c -c %-------------------------------------% -c | Select the wanted Ritz values. | -c | Sort the Ritz values so that the | -c | wanted ones appear at the tailing | -c | NEV positions of workl(irr) and | -c | workl(iri). Move the corresponding | -c | error estimates in workl(bound) | -c | accordingly. | -c %-------------------------------------% -c - np = ncv - nev - ishift = 0 - call dsgets (ishift, which , nev , - & np , workl(irz) , workl(bounds), - & workl) -c - if (msglvl .gt. 2) then - call dvout (logfil, ncv, workl(irz), ndigit, - & '_seupd: Ritz values after calling _SGETS.') - call dvout (logfil, ncv, workl(bounds), ndigit, - & '_seupd: Ritz value indices after calling _SGETS.') - end if -c -c %-----------------------------------------------------% -c | Record indices of the converged wanted Ritz values | -c | Mark the select array for possible reordering | -c %-----------------------------------------------------% -c - numcnv = 0 - do 11 j = 1,ncv - temp1 = max(eps23, abs(workl(irz+ncv-j)) ) - jj = workl(bounds + ncv - j) - if (numcnv .lt. nconv .and. - & workl(ibd+jj-1) .le. tol*temp1) then - select(jj) = .true. - numcnv = numcnv + 1 - if (jj .gt. nev) reord = .true. - endif - 11 continue -c -c %-----------------------------------------------------------% -c | Check the count (numcnv) of converged Ritz values with | -c | the number (nconv) reported by _saupd. If these two | -c | are different then there has probably been an error | -c | caused by incorrect passing of the _saupd data. | -c %-----------------------------------------------------------% -c - if (msglvl .gt. 2) then - call ivout(logfil, 1, numcnv, ndigit, - & '_seupd: Number of specified eigenvalues') - call ivout(logfil, 1, nconv, ndigit, - & '_seupd: Number of "converged" eigenvalues') - end if -c - if (numcnv .ne. nconv) then - info = -17 - go to 9000 - end if -c -c %-----------------------------------------------------------% -c | Call LAPACK routine _steqr to compute the eigenvalues and | -c | eigenvectors of the final symmetric tridiagonal matrix H. | -c | Initialize the eigenvector matrix Q to the identity. | -c %-----------------------------------------------------------% -c - call dcopy (ncv-1, workl(ih+1), 1, workl(ihb), 1) - call dcopy (ncv, workl(ih+ldh), 1, workl(ihd), 1) -c - call dsteqr ('Identity', ncv, workl(ihd), workl(ihb), - & workl(iq) , ldq, workl(iw), ierr) -c - if (ierr .ne. 0) then - info = -8 - go to 9000 - end if -c - if (msglvl .gt. 1) then - call dcopy (ncv, workl(iq+ncv-1), ldq, workl(iw), 1) - call dvout (logfil, ncv, workl(ihd), ndigit, - & '_seupd: NCV Ritz values of the final H matrix') - call dvout (logfil, ncv, workl(iw), ndigit, - & '_seupd: last row of the eigenvector matrix for H') - end if -c - if (reord) then -c -c %---------------------------------------------% -c | Reordered the eigenvalues and eigenvectors | -c | computed by _steqr so that the "converged" | -c | eigenvalues appear in the first NCONV | -c | positions of workl(ihd), and the associated | -c | eigenvectors appear in the first NCONV | -c | columns. | -c %---------------------------------------------% -c - leftptr = 1 - rghtptr = ncv -c - if (ncv .eq. 1) go to 30 -c - 20 if (select(leftptr)) then -c -c %-------------------------------------------% -c | Search, from the left, for the first Ritz | -c | value that has not converged. | -c %-------------------------------------------% -c - leftptr = leftptr + 1 -c - else if ( .not. select(rghtptr)) then -c -c %----------------------------------------------% -c | Search, from the right, the first Ritz value | -c | that has converged. | -c %----------------------------------------------% -c - rghtptr = rghtptr - 1 -c - else -c -c %----------------------------------------------% -c | Swap the Ritz value on the left that has not | -c | converged with the Ritz value on the right | -c | that has converged. Swap the associated | -c | eigenvector of the tridiagonal matrix H as | -c | well. | -c %----------------------------------------------% -c - temp = workl(ihd+leftptr-1) - workl(ihd+leftptr-1) = workl(ihd+rghtptr-1) - workl(ihd+rghtptr-1) = temp - call dcopy (ncv, workl(iq+ncv*(leftptr-1)), 1, - & workl(iw), 1) - call dcopy (ncv, workl(iq+ncv*(rghtptr-1)), 1, - & workl(iq+ncv*(leftptr-1)), 1) - call dcopy (ncv, workl(iw), 1, - & workl(iq+ncv*(rghtptr-1)), 1) - leftptr = leftptr + 1 - rghtptr = rghtptr - 1 -c - end if -c - if (leftptr .lt. rghtptr) go to 20 -c - end if -c - 30 if (msglvl .gt. 2) then - call dvout (logfil, ncv, workl(ihd), ndigit, - & '_seupd: The eigenvalues of H--reordered') - end if -c -c %----------------------------------------% -c | Load the converged Ritz values into D. | -c %----------------------------------------% -c - call dcopy (nconv, workl(ihd), 1, d, 1) -c - else -c -c %-----------------------------------------------------% -c | Ritz vectors not required. Load Ritz values into D. | -c %-----------------------------------------------------% -c - call dcopy (nconv, workl(ritz), 1, d, 1) - call dcopy (ncv, workl(ritz), 1, workl(ihd), 1) -c - end if -c -c %------------------------------------------------------------------% -c | Transform the Ritz values and possibly vectors and corresponding | -c | Ritz estimates of OP to those of A*x=lambda*B*x. The Ritz values | -c | (and corresponding data) are returned in ascending order. | -c %------------------------------------------------------------------% -c - if (type .eq. 'REGULR') then -c -c %---------------------------------------------------------% -c | Ascending sort of wanted Ritz values, vectors and error | -c | bounds. Not necessary if only Ritz values are desired. | -c %---------------------------------------------------------% -c - if (rvec) then - call dsesrt ('LA', rvec , nconv, d, ncv, workl(iq), ldq) - else - call dcopy (ncv, workl(bounds), 1, workl(ihb), 1) - end if -c - else -c -c %-------------------------------------------------------------% -c | * Make a copy of all the Ritz values. | -c | * Transform the Ritz values back to the original system. | -c | For TYPE = 'SHIFTI' the transformation is | -c | lambda = 1/theta + sigma | -c | For TYPE = 'BUCKLE' the transformation is | -c | lambda = sigma * theta / ( theta - 1 ) | -c | For TYPE = 'CAYLEY' the transformation is | -c | lambda = sigma * (theta + 1) / (theta - 1 ) | -c | where the theta are the Ritz values returned by dsaupd . | -c | NOTES: | -c | *The Ritz vectors are not affected by the transformation. | -c | They are only reordered. | -c %-------------------------------------------------------------% -c - call dcopy (ncv, workl(ihd), 1, workl(iw), 1) - if (type .eq. 'SHIFTI') then - do 40 k=1, ncv - workl(ihd+k-1) = one / workl(ihd+k-1) + sigma - 40 continue - else if (type .eq. 'BUCKLE') then - do 50 k=1, ncv - workl(ihd+k-1) = sigma * workl(ihd+k-1) / - & (workl(ihd+k-1) - one) - 50 continue - else if (type .eq. 'CAYLEY') then - do 60 k=1, ncv - workl(ihd+k-1) = sigma * (workl(ihd+k-1) + one) / - & (workl(ihd+k-1) - one) - 60 continue - end if -c -c %-------------------------------------------------------------% -c | * Store the wanted NCONV lambda values into D. | -c | * Sort the NCONV wanted lambda in WORKL(IHD:IHD+NCONV-1) | -c | into ascending order and apply sort to the NCONV theta | -c | values in the transformed system. We will need this to | -c | compute Ritz estimates in the original system. | -c | * Finally sort the lambda`s into ascending order and apply | -c | to Ritz vectors if wanted. Else just sort lambda`s into | -c | ascending order. | -c | NOTES: | -c | *workl(iw:iw+ncv-1) contain the theta ordered so that they | -c | match the ordering of the lambda. We`ll use them again for | -c | Ritz vector purification. | -c %-------------------------------------------------------------% -c - call dcopy (nconv, workl(ihd), 1, d, 1) - call dsortr ('LA', .true., nconv, workl(ihd), workl(iw)) - if (rvec) then - call dsesrt ('LA', rvec , nconv, d, ncv, workl(iq), ldq) - else - call dcopy (ncv, workl(bounds), 1, workl(ihb), 1) - call dscal (ncv, bnorm2/rnorm, workl(ihb), 1) - call dsortr ('LA', .true., nconv, d, workl(ihb)) - end if -c - end if -c -c %------------------------------------------------% -c | Compute the Ritz vectors. Transform the wanted | -c | eigenvectors of the symmetric tridiagonal H by | -c | the Lanczos basis matrix V. | -c %------------------------------------------------% -c - if (rvec .and. howmny .eq. 'A') then -c -c %----------------------------------------------------------% -c | Compute the QR factorization of the matrix representing | -c | the wanted invariant subspace located in the first NCONV | -c | columns of workl(iq,ldq). | -c %----------------------------------------------------------% -c - call dgeqr2 (ncv, nconv , workl(iq) , - & ldq, workl(iw+ncv), workl(ihb), - & ierr) -c -c %--------------------------------------------------------% -c | * Postmultiply V by Q. | -c | * Copy the first NCONV columns of VQ into Z. | -c | The N by NCONV matrix Z is now a matrix representation | -c | of the approximate invariant subspace associated with | -c | the Ritz values in workl(ihd). | -c %--------------------------------------------------------% -c - call dorm2r ('Right', 'Notranspose', n , - & ncv , nconv , workl(iq), - & ldq , workl(iw+ncv), v , - & ldv , workd(n+1) , ierr) - call dlacpy ('All', n, nconv, v, ldv, z, ldz) -c -c %-----------------------------------------------------% -c | In order to compute the Ritz estimates for the Ritz | -c | values in both systems, need the last row of the | -c | eigenvector matrix. Remember, it`s in factored form | -c %-----------------------------------------------------% -c - do 65 j = 1, ncv-1 - workl(ihb+j-1) = zero - 65 continue - workl(ihb+ncv-1) = one - call dorm2r ('Left', 'Transpose' , ncv , - & 1 , nconv , workl(iq) , - & ldq , workl(iw+ncv), workl(ihb), - & ncv , temp , ierr) -c - else if (rvec .and. howmny .eq. 'S') then -c -c Not yet implemented. See remark 2 above. -c - end if -c - if (type .eq. 'REGULR' .and. rvec) then -c - do 70 j=1, ncv - workl(ihb+j-1) = rnorm * abs( workl(ihb+j-1) ) - 70 continue -c - else if (type .ne. 'REGULR' .and. rvec) then -c -c %-------------------------------------------------% -c | * Determine Ritz estimates of the theta. | -c | If RVEC = .true. then compute Ritz estimates | -c | of the theta. | -c | If RVEC = .false. then copy Ritz estimates | -c | as computed by dsaupd . | -c | * Determine Ritz estimates of the lambda. | -c %-------------------------------------------------% -c - call dscal (ncv, bnorm2, workl(ihb), 1) - if (type .eq. 'SHIFTI') then -c - do 80 k=1, ncv - workl(ihb+k-1) = abs( workl(ihb+k-1) ) - & / workl(iw+k-1)**2 - 80 continue -c - else if (type .eq. 'BUCKLE') then -c - do 90 k=1, ncv - workl(ihb+k-1) = sigma * abs( workl(ihb+k-1) ) - & / (workl(iw+k-1)-one )**2 - 90 continue -c - else if (type .eq. 'CAYLEY') then -c - do 100 k=1, ncv - workl(ihb+k-1) = abs( workl(ihb+k-1) - & / workl(iw+k-1)*(workl(iw+k-1)-one) ) - 100 continue -c - end if -c - end if -c - if (type .ne. 'REGULR' .and. msglvl .gt. 1) then - call dvout (logfil, nconv, d, ndigit, - & '_seupd: Untransformed converged Ritz values') - call dvout (logfil, nconv, workl(ihb), ndigit, - & '_seupd: Ritz estimates of the untransformed Ritz values') - else if (msglvl .gt. 1) then - call dvout (logfil, nconv, d, ndigit, - & '_seupd: Converged Ritz values') - call dvout (logfil, nconv, workl(ihb), ndigit, - & '_seupd: Associated Ritz estimates') - end if -c -c %-------------------------------------------------% -c | Ritz vector purification step. Formally perform | -c | one of inverse subspace iteration. Only used | -c | for MODE = 3,4,5. See reference 7 | -c %-------------------------------------------------% -c - if (rvec .and. (type .eq. 'SHIFTI' .or. type .eq. 'CAYLEY')) then -c - do 110 k=0, nconv-1 - workl(iw+k) = workl(iq+k*ldq+ncv-1) - & / workl(iw+k) - 110 continue -c - else if (rvec .and. type .eq. 'BUCKLE') then -c - do 120 k=0, nconv-1 - workl(iw+k) = workl(iq+k*ldq+ncv-1) - & / (workl(iw+k)-one) - 120 continue -c - end if -c - if (type .ne. 'REGULR') - & call dger (n, nconv, one, resid, 1, workl(iw), 1, z, ldz) -c - 9000 continue -c - return -c -c %---------------% -c | End of dseupd | -c %---------------% -c - end
--- a/libcruft/arpack/src/dsgets.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,219 +0,0 @@ -c----------------------------------------------------------------------- -c\BeginDoc -c -c\Name: dsgets -c -c\Description: -c Given the eigenvalues of the symmetric tridiagonal matrix H, -c computes the NP shifts AMU that are zeros of the polynomial of -c degree NP which filters out components of the unwanted eigenvectors -c corresponding to the AMU's based on some given criteria. -c -c NOTE: This is called even in the case of user specified shifts in -c order to sort the eigenvalues, and error bounds of H for later use. -c -c\Usage: -c call dsgets -c ( ISHIFT, WHICH, KEV, NP, RITZ, BOUNDS, SHIFTS ) -c -c\Arguments -c ISHIFT Integer. (INPUT) -c Method for selecting the implicit shifts at each iteration. -c ISHIFT = 0: user specified shifts -c ISHIFT = 1: exact shift with respect to the matrix H. -c -c WHICH Character*2. (INPUT) -c Shift selection criteria. -c 'LM' -> KEV eigenvalues of largest magnitude are retained. -c 'SM' -> KEV eigenvalues of smallest magnitude are retained. -c 'LA' -> KEV eigenvalues of largest value are retained. -c 'SA' -> KEV eigenvalues of smallest value are retained. -c 'BE' -> KEV eigenvalues, half from each end of the spectrum. -c If KEV is odd, compute one more from the high end. -c -c KEV Integer. (INPUT) -c KEV+NP is the size of the matrix H. -c -c NP Integer. (INPUT) -c Number of implicit shifts to be computed. -c -c RITZ Double precision array of length KEV+NP. (INPUT/OUTPUT) -c On INPUT, RITZ contains the eigenvalues of H. -c On OUTPUT, RITZ are sorted so that the unwanted eigenvalues -c are in the first NP locations and the wanted part is in -c the last KEV locations. When exact shifts are selected, the -c unwanted part corresponds to the shifts to be applied. -c -c BOUNDS Double precision array of length KEV+NP. (INPUT/OUTPUT) -c Error bounds corresponding to the ordering in RITZ. -c -c SHIFTS Double precision array of length NP. (INPUT/OUTPUT) -c On INPUT: contains the user specified shifts if ISHIFT = 0. -c On OUTPUT: contains the shifts sorted into decreasing order -c of magnitude with respect to the Ritz estimates contained in -c BOUNDS. If ISHIFT = 0, SHIFTS is not modified on exit. -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Local variables: -c xxxxxx real -c -c\Routines called: -c dsortr ARPACK utility sorting routine. -c ivout ARPACK utility routine that prints integers. -c arscnd ARPACK utility routine for timing. -c dvout ARPACK utility routine that prints vectors. -c dcopy Level 1 BLAS that copies one vector to another. -c dswap Level 1 BLAS that swaps the contents of two vectors. -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\Revision history: -c xx/xx/93: Version ' 2.1' -c -c\SCCS Information: @(#) -c FILE: sgets.F SID: 2.4 DATE OF SID: 4/19/96 RELEASE: 2 -c -c\Remarks -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine dsgets ( ishift, which, kev, np, ritz, bounds, shifts ) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - character*2 which - integer ishift, kev, np -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - Double precision - & bounds(kev+np), ritz(kev+np), shifts(np) -c -c %------------% -c | Parameters | -c %------------% -c - Double precision - & one, zero - parameter (one = 1.0D+0, zero = 0.0D+0) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - integer kevd2, msglvl -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external dswap, dcopy, dsortr, arscnd -c -c %---------------------% -c | Intrinsic Functions | -c %---------------------% -c - intrinsic max, min -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c -c %-------------------------------% -c | Initialize timing statistics | -c | & message level for debugging | -c %-------------------------------% -c - call arscnd (t0) - msglvl = msgets -c - if (which .eq. 'BE') then -c -c %-----------------------------------------------------% -c | Both ends of the spectrum are requested. | -c | Sort the eigenvalues into algebraically increasing | -c | order first then swap high end of the spectrum next | -c | to low end in appropriate locations. | -c | NOTE: when np < floor(kev/2) be careful not to swap | -c | overlapping locations. | -c %-----------------------------------------------------% -c - call dsortr ('LA', .true., kev+np, ritz, bounds) - kevd2 = kev / 2 - if ( kev .gt. 1 ) then - call dswap ( min(kevd2,np), ritz, 1, - & ritz( max(kevd2,np)+1 ), 1) - call dswap ( min(kevd2,np), bounds, 1, - & bounds( max(kevd2,np)+1 ), 1) - end if -c - else -c -c %----------------------------------------------------% -c | LM, SM, LA, SA case. | -c | Sort the eigenvalues of H into the desired order | -c | and apply the resulting order to BOUNDS. | -c | The eigenvalues are sorted so that the wanted part | -c | are always in the last KEV locations. | -c %----------------------------------------------------% -c - call dsortr (which, .true., kev+np, ritz, bounds) - end if -c - if (ishift .eq. 1 .and. np .gt. 0) then -c -c %-------------------------------------------------------% -c | Sort the unwanted Ritz values used as shifts so that | -c | the ones with largest Ritz estimates are first. | -c | This will tend to minimize the effects of the | -c | forward instability of the iteration when the shifts | -c | are applied in subroutine dsapps. | -c %-------------------------------------------------------% -c - call dsortr ('SM', .true., np, bounds, ritz) - call dcopy (np, ritz, 1, shifts, 1) - end if -c - call arscnd (t1) - tsgets = tsgets + (t1 - t0) -c - if (msglvl .gt. 0) then - call ivout (logfil, 1, kev, ndigit, '_sgets: KEV is') - call ivout (logfil, 1, np, ndigit, '_sgets: NP is') - call dvout (logfil, kev+np, ritz, ndigit, - & '_sgets: Eigenvalues of current H matrix') - call dvout (logfil, kev+np, bounds, ndigit, - & '_sgets: Associated Ritz estimates') - end if -c - return -c -c %---------------% -c | End of dsgets | -c %---------------% -c - end
--- a/libcruft/arpack/src/dsortc.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,344 +0,0 @@ -c----------------------------------------------------------------------- -c\BeginDoc -c -c\Name: dsortc -c -c\Description: -c Sorts the complex array in XREAL and XIMAG into the order -c specified by WHICH and optionally applies the permutation to the -c real array Y. It is assumed that if an element of XIMAG is -c nonzero, then its negative is also an element. In other words, -c both members of a complex conjugate pair are to be sorted and the -c pairs are kept adjacent to each other. -c -c\Usage: -c call dsortc -c ( WHICH, APPLY, N, XREAL, XIMAG, Y ) -c -c\Arguments -c WHICH Character*2. (Input) -c 'LM' -> sort XREAL,XIMAG into increasing order of magnitude. -c 'SM' -> sort XREAL,XIMAG into decreasing order of magnitude. -c 'LR' -> sort XREAL into increasing order of algebraic. -c 'SR' -> sort XREAL into decreasing order of algebraic. -c 'LI' -> sort XIMAG into increasing order of magnitude. -c 'SI' -> sort XIMAG into decreasing order of magnitude. -c NOTE: If an element of XIMAG is non-zero, then its negative -c is also an element. -c -c APPLY Logical. (Input) -c APPLY = .TRUE. -> apply the sorted order to array Y. -c APPLY = .FALSE. -> do not apply the sorted order to array Y. -c -c N Integer. (INPUT) -c Size of the arrays. -c -c XREAL, Double precision array of length N. (INPUT/OUTPUT) -c XIMAG Real and imaginary part of the array to be sorted. -c -c Y Double precision array of length N. (INPUT/OUTPUT) -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\Revision history: -c xx/xx/92: Version ' 2.1' -c Adapted from the sort routine in LANSO. -c -c\SCCS Information: @(#) -c FILE: sortc.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2 -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine dsortc (which, apply, n, xreal, ximag, y) -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - character*2 which - logical apply - integer n -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - Double precision - & xreal(0:n-1), ximag(0:n-1), y(0:n-1) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - integer i, igap, j - Double precision - & temp, temp1, temp2 -c -c %--------------------% -c | External Functions | -c %--------------------% -c - Double precision - & dlapy2 - external dlapy2 -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c - igap = n / 2 -c - if (which .eq. 'LM') then -c -c %------------------------------------------------------% -c | Sort XREAL,XIMAG into increasing order of magnitude. | -c %------------------------------------------------------% -c - 10 continue - if (igap .eq. 0) go to 9000 -c - do 30 i = igap, n-1 - j = i-igap - 20 continue -c - if (j.lt.0) go to 30 -c - temp1 = dlapy2(xreal(j),ximag(j)) - temp2 = dlapy2(xreal(j+igap),ximag(j+igap)) -c - if (temp1.gt.temp2) then - temp = xreal(j) - xreal(j) = xreal(j+igap) - xreal(j+igap) = temp -c - temp = ximag(j) - ximag(j) = ximag(j+igap) - ximag(j+igap) = temp -c - if (apply) then - temp = y(j) - y(j) = y(j+igap) - y(j+igap) = temp - end if - else - go to 30 - end if - j = j-igap - go to 20 - 30 continue - igap = igap / 2 - go to 10 -c - else if (which .eq. 'SM') then -c -c %------------------------------------------------------% -c | Sort XREAL,XIMAG into decreasing order of magnitude. | -c %------------------------------------------------------% -c - 40 continue - if (igap .eq. 0) go to 9000 -c - do 60 i = igap, n-1 - j = i-igap - 50 continue -c - if (j .lt. 0) go to 60 -c - temp1 = dlapy2(xreal(j),ximag(j)) - temp2 = dlapy2(xreal(j+igap),ximag(j+igap)) -c - if (temp1.lt.temp2) then - temp = xreal(j) - xreal(j) = xreal(j+igap) - xreal(j+igap) = temp -c - temp = ximag(j) - ximag(j) = ximag(j+igap) - ximag(j+igap) = temp -c - if (apply) then - temp = y(j) - y(j) = y(j+igap) - y(j+igap) = temp - end if - else - go to 60 - endif - j = j-igap - go to 50 - 60 continue - igap = igap / 2 - go to 40 -c - else if (which .eq. 'LR') then -c -c %------------------------------------------------% -c | Sort XREAL into increasing order of algebraic. | -c %------------------------------------------------% -c - 70 continue - if (igap .eq. 0) go to 9000 -c - do 90 i = igap, n-1 - j = i-igap - 80 continue -c - if (j.lt.0) go to 90 -c - if (xreal(j).gt.xreal(j+igap)) then - temp = xreal(j) - xreal(j) = xreal(j+igap) - xreal(j+igap) = temp -c - temp = ximag(j) - ximag(j) = ximag(j+igap) - ximag(j+igap) = temp -c - if (apply) then - temp = y(j) - y(j) = y(j+igap) - y(j+igap) = temp - end if - else - go to 90 - endif - j = j-igap - go to 80 - 90 continue - igap = igap / 2 - go to 70 -c - else if (which .eq. 'SR') then -c -c %------------------------------------------------% -c | Sort XREAL into decreasing order of algebraic. | -c %------------------------------------------------% -c - 100 continue - if (igap .eq. 0) go to 9000 - do 120 i = igap, n-1 - j = i-igap - 110 continue -c - if (j.lt.0) go to 120 -c - if (xreal(j).lt.xreal(j+igap)) then - temp = xreal(j) - xreal(j) = xreal(j+igap) - xreal(j+igap) = temp -c - temp = ximag(j) - ximag(j) = ximag(j+igap) - ximag(j+igap) = temp -c - if (apply) then - temp = y(j) - y(j) = y(j+igap) - y(j+igap) = temp - end if - else - go to 120 - endif - j = j-igap - go to 110 - 120 continue - igap = igap / 2 - go to 100 -c - else if (which .eq. 'LI') then -c -c %------------------------------------------------% -c | Sort XIMAG into increasing order of magnitude. | -c %------------------------------------------------% -c - 130 continue - if (igap .eq. 0) go to 9000 - do 150 i = igap, n-1 - j = i-igap - 140 continue -c - if (j.lt.0) go to 150 -c - if (abs(ximag(j)).gt.abs(ximag(j+igap))) then - temp = xreal(j) - xreal(j) = xreal(j+igap) - xreal(j+igap) = temp -c - temp = ximag(j) - ximag(j) = ximag(j+igap) - ximag(j+igap) = temp -c - if (apply) then - temp = y(j) - y(j) = y(j+igap) - y(j+igap) = temp - end if - else - go to 150 - endif - j = j-igap - go to 140 - 150 continue - igap = igap / 2 - go to 130 -c - else if (which .eq. 'SI') then -c -c %------------------------------------------------% -c | Sort XIMAG into decreasing order of magnitude. | -c %------------------------------------------------% -c - 160 continue - if (igap .eq. 0) go to 9000 - do 180 i = igap, n-1 - j = i-igap - 170 continue -c - if (j.lt.0) go to 180 -c - if (abs(ximag(j)).lt.abs(ximag(j+igap))) then - temp = xreal(j) - xreal(j) = xreal(j+igap) - xreal(j+igap) = temp -c - temp = ximag(j) - ximag(j) = ximag(j+igap) - ximag(j+igap) = temp -c - if (apply) then - temp = y(j) - y(j) = y(j+igap) - y(j+igap) = temp - end if - else - go to 180 - endif - j = j-igap - go to 170 - 180 continue - igap = igap / 2 - go to 160 - end if -c - 9000 continue - return -c -c %---------------% -c | End of dsortc | -c %---------------% -c - end
--- a/libcruft/arpack/src/dsortr.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,218 +0,0 @@ -c----------------------------------------------------------------------- -c\BeginDoc -c -c\Name: dsortr -c -c\Description: -c Sort the array X1 in the order specified by WHICH and optionally -c applies the permutation to the array X2. -c -c\Usage: -c call dsortr -c ( WHICH, APPLY, N, X1, X2 ) -c -c\Arguments -c WHICH Character*2. (Input) -c 'LM' -> X1 is sorted into increasing order of magnitude. -c 'SM' -> X1 is sorted into decreasing order of magnitude. -c 'LA' -> X1 is sorted into increasing order of algebraic. -c 'SA' -> X1 is sorted into decreasing order of algebraic. -c -c APPLY Logical. (Input) -c APPLY = .TRUE. -> apply the sorted order to X2. -c APPLY = .FALSE. -> do not apply the sorted order to X2. -c -c N Integer. (INPUT) -c Size of the arrays. -c -c X1 Double precision array of length N. (INPUT/OUTPUT) -c The array to be sorted. -c -c X2 Double precision array of length N. (INPUT/OUTPUT) -c Only referenced if APPLY = .TRUE. -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\Revision history: -c 12/16/93: Version ' 2.1'. -c Adapted from the sort routine in LANSO. -c -c\SCCS Information: @(#) -c FILE: sortr.F SID: 2.3 DATE OF SID: 4/19/96 RELEASE: 2 -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine dsortr (which, apply, n, x1, x2) -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - character*2 which - logical apply - integer n -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - Double precision - & x1(0:n-1), x2(0:n-1) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - integer i, igap, j - Double precision - & temp -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c - igap = n / 2 -c - if (which .eq. 'SA') then -c -c X1 is sorted into decreasing order of algebraic. -c - 10 continue - if (igap .eq. 0) go to 9000 - do 30 i = igap, n-1 - j = i-igap - 20 continue -c - if (j.lt.0) go to 30 -c - if (x1(j).lt.x1(j+igap)) then - temp = x1(j) - x1(j) = x1(j+igap) - x1(j+igap) = temp - if (apply) then - temp = x2(j) - x2(j) = x2(j+igap) - x2(j+igap) = temp - end if - else - go to 30 - endif - j = j-igap - go to 20 - 30 continue - igap = igap / 2 - go to 10 -c - else if (which .eq. 'SM') then -c -c X1 is sorted into decreasing order of magnitude. -c - 40 continue - if (igap .eq. 0) go to 9000 - do 60 i = igap, n-1 - j = i-igap - 50 continue -c - if (j.lt.0) go to 60 -c - if (abs(x1(j)).lt.abs(x1(j+igap))) then - temp = x1(j) - x1(j) = x1(j+igap) - x1(j+igap) = temp - if (apply) then - temp = x2(j) - x2(j) = x2(j+igap) - x2(j+igap) = temp - end if - else - go to 60 - endif - j = j-igap - go to 50 - 60 continue - igap = igap / 2 - go to 40 -c - else if (which .eq. 'LA') then -c -c X1 is sorted into increasing order of algebraic. -c - 70 continue - if (igap .eq. 0) go to 9000 - do 90 i = igap, n-1 - j = i-igap - 80 continue -c - if (j.lt.0) go to 90 -c - if (x1(j).gt.x1(j+igap)) then - temp = x1(j) - x1(j) = x1(j+igap) - x1(j+igap) = temp - if (apply) then - temp = x2(j) - x2(j) = x2(j+igap) - x2(j+igap) = temp - end if - else - go to 90 - endif - j = j-igap - go to 80 - 90 continue - igap = igap / 2 - go to 70 -c - else if (which .eq. 'LM') then -c -c X1 is sorted into increasing order of magnitude. -c - 100 continue - if (igap .eq. 0) go to 9000 - do 120 i = igap, n-1 - j = i-igap - 110 continue -c - if (j.lt.0) go to 120 -c - if (abs(x1(j)).gt.abs(x1(j+igap))) then - temp = x1(j) - x1(j) = x1(j+igap) - x1(j+igap) = temp - if (apply) then - temp = x2(j) - x2(j) = x2(j+igap) - x2(j+igap) = temp - end if - else - go to 120 - endif - j = j-igap - go to 110 - 120 continue - igap = igap / 2 - go to 100 - end if -c - 9000 continue - return -c -c %---------------% -c | End of dsortr | -c %---------------% -c - end
--- a/libcruft/arpack/src/dstatn.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,61 +0,0 @@ -c -c %---------------------------------------------% -c | Initialize statistic and timing information | -c | for nonsymmetric Arnoldi code. | -c %---------------------------------------------% -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\SCCS Information: @(#) -c FILE: statn.F SID: 2.4 DATE OF SID: 4/20/96 RELEASE: 2 -c - subroutine dstatn -c -c %--------------------------------% -c | See stat.doc for documentation | -c %--------------------------------% -c - include 'stat.h' -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c - nopx = 0 - nbx = 0 - nrorth = 0 - nitref = 0 - nrstrt = 0 -c - tnaupd = 0.0D+0 - tnaup2 = 0.0D+0 - tnaitr = 0.0D+0 - tneigh = 0.0D+0 - tngets = 0.0D+0 - tnapps = 0.0D+0 - tnconv = 0.0D+0 - titref = 0.0D+0 - tgetv0 = 0.0D+0 - trvec = 0.0D+0 -c -c %----------------------------------------------------% -c | User time including reverse communication overhead | -c %----------------------------------------------------% -c - tmvopx = 0.0D+0 - tmvbx = 0.0D+0 -c - return -c -c -c %---------------% -c | End of dstatn | -c %---------------% -c - end
--- a/libcruft/arpack/src/dstats.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,47 +0,0 @@ -c -c\SCCS Information: @(#) -c FILE: stats.F SID: 2.1 DATE OF SID: 4/19/96 RELEASE: 2 -c %---------------------------------------------% -c | Initialize statistic and timing information | -c | for symmetric Arnoldi code. | -c %---------------------------------------------% - - subroutine dstats - -c %--------------------------------% -c | See stat.doc for documentation | -c %--------------------------------% - include 'stat.h' - -c %-----------------------% -c | Executable Statements | -c %-----------------------% - - nopx = 0 - nbx = 0 - nrorth = 0 - nitref = 0 - nrstrt = 0 - - tsaupd = 0.0D+0 - tsaup2 = 0.0D+0 - tsaitr = 0.0D+0 - tseigt = 0.0D+0 - tsgets = 0.0D+0 - tsapps = 0.0D+0 - tsconv = 0.0D+0 - titref = 0.0D+0 - tgetv0 = 0.0D+0 - trvec = 0.0D+0 - -c %----------------------------------------------------% -c | User time including reverse communication overhead | -c %----------------------------------------------------% - tmvopx = 0.0D+0 - tmvbx = 0.0D+0 - - return -c -c End of dstats -c - end
--- a/libcruft/arpack/src/dstqrb.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,594 +0,0 @@ -c----------------------------------------------------------------------- -c\BeginDoc -c -c\Name: dstqrb -c -c\Description: -c Computes all eigenvalues and the last component of the eigenvectors -c of a symmetric tridiagonal matrix using the implicit QL or QR method. -c -c This is mostly a modification of the LAPACK routine dsteqr. -c See Remarks. -c -c\Usage: -c call dstqrb -c ( N, D, E, Z, WORK, INFO ) -c -c\Arguments -c N Integer. (INPUT) -c The number of rows and columns in the matrix. N >= 0. -c -c D Double precision array, dimension (N). (INPUT/OUTPUT) -c On entry, D contains the diagonal elements of the -c tridiagonal matrix. -c On exit, D contains the eigenvalues, in ascending order. -c If an error exit is made, the eigenvalues are correct -c for indices 1,2,...,INFO-1, but they are unordered and -c may not be the smallest eigenvalues of the matrix. -c -c E Double precision array, dimension (N-1). (INPUT/OUTPUT) -c On entry, E contains the subdiagonal elements of the -c tridiagonal matrix in positions 1 through N-1. -c On exit, E has been destroyed. -c -c Z Double precision array, dimension (N). (OUTPUT) -c On exit, Z contains the last row of the orthonormal -c eigenvector matrix of the symmetric tridiagonal matrix. -c If an error exit is made, Z contains the last row of the -c eigenvector matrix associated with the stored eigenvalues. -c -c WORK Double precision array, dimension (max(1,2*N-2)). (WORKSPACE) -c Workspace used in accumulating the transformation for -c computing the last components of the eigenvectors. -c -c INFO Integer. (OUTPUT) -c = 0: normal return. -c < 0: if INFO = -i, the i-th argument had an illegal value. -c > 0: if INFO = +i, the i-th eigenvalue has not converged -c after a total of 30*N iterations. -c -c\Remarks -c 1. None. -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Local variables: -c xxxxxx real -c -c\Routines called: -c daxpy Level 1 BLAS that computes a vector triad. -c dcopy Level 1 BLAS that copies one vector to another. -c dswap Level 1 BLAS that swaps the contents of two vectors. -c lsame LAPACK character comparison routine. -c dlae2 LAPACK routine that computes the eigenvalues of a 2-by-2 -c symmetric matrix. -c dlaev2 LAPACK routine that eigendecomposition of a 2-by-2 symmetric -c matrix. -c dlamch LAPACK routine that determines machine constants. -c dlanst LAPACK routine that computes the norm of a matrix. -c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. -c dlartg LAPACK Givens rotation construction routine. -c dlascl LAPACK routine for careful scaling of a matrix. -c dlaset LAPACK matrix initialization routine. -c dlasr LAPACK routine that applies an orthogonal transformation to -c a matrix. -c dlasrt LAPACK sorting routine. -c dsteqr LAPACK routine that computes eigenvalues and eigenvectors -c of a symmetric tridiagonal matrix. -c xerbla LAPACK error handler routine. -c -c\Authors -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\SCCS Information: @(#) -c FILE: stqrb.F SID: 2.5 DATE OF SID: 8/27/96 RELEASE: 2 -c -c\Remarks -c 1. Starting with version 2.5, this routine is a modified version -c of LAPACK version 2.0 subroutine SSTEQR. No lines are deleted, -c only commeted out and new lines inserted. -c All lines commented out have "c$$$" at the beginning. -c Note that the LAPACK version 1.0 subroutine SSTEQR contained -c bugs. -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine dstqrb ( n, d, e, z, work, info ) -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - integer info, n -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - Double precision - & d( n ), e( n-1 ), z( n ), work( 2*n-2 ) -c -c .. parameters .. - Double precision - & zero, one, two, three - parameter ( zero = 0.0D+0, one = 1.0D+0, - & two = 2.0D+0, three = 3.0D+0 ) - integer maxit - parameter ( maxit = 30 ) -c .. -c .. 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 -c .. -c .. external functions .. - logical lsame - Double precision - & dlamch, dlanst, dlapy2 - external lsame, dlamch, dlanst, dlapy2 -c .. -c .. external subroutines .. - external dlae2, dlaev2, dlartg, dlascl, dlaset, dlasr, - & dlasrt, dswap, xerbla -c .. -c .. intrinsic functions .. - intrinsic abs, max, sign, sqrt -c .. -c .. executable statements .. -c -c test the input parameters. -c - info = 0 -c -c$$$ IF( LSAME( COMPZ, 'N' ) ) THEN -c$$$ ICOMPZ = 0 -c$$$ ELSE IF( LSAME( COMPZ, 'V' ) ) THEN -c$$$ ICOMPZ = 1 -c$$$ ELSE IF( LSAME( COMPZ, 'I' ) ) THEN -c$$$ ICOMPZ = 2 -c$$$ ELSE -c$$$ ICOMPZ = -1 -c$$$ END IF -c$$$ IF( ICOMPZ.LT.0 ) THEN -c$$$ INFO = -1 -c$$$ ELSE IF( N.LT.0 ) THEN -c$$$ INFO = -2 -c$$$ ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, -c$$$ $ N ) ) ) THEN -c$$$ INFO = -6 -c$$$ END IF -c$$$ IF( INFO.NE.0 ) THEN -c$$$ CALL XERBLA( 'SSTEQR', -INFO ) -c$$$ RETURN -c$$$ END IF -c -c *** New starting with version 2.5 *** -c - icompz = 2 -c ************************************* -c -c quick return if possible -c - if( n.eq.0 ) - $ return -c - if( n.eq.1 ) then - if( icompz.eq.2 ) z( 1 ) = one - return - end if -c -c determine the unit roundoff and over/underflow thresholds. -c - eps = dlamch( 'e' ) - eps2 = eps**2 - safmin = dlamch( 's' ) - safmax = one / safmin - ssfmax = sqrt( safmax ) / three - ssfmin = sqrt( safmin ) / eps2 -c -c compute the eigenvalues and eigenvectors of the tridiagonal -c matrix. -c -c$$ if( icompz.eq.2 ) -c$$$ $ call dlaset( 'full', n, n, zero, one, z, ldz ) -c -c *** New starting with version 2.5 *** -c - if ( icompz .eq. 2 ) then - do 5 j = 1, n-1 - z(j) = zero - 5 continue - z( n ) = one - end if -c ************************************* -c - nmaxit = n*maxit - jtot = 0 -c -c determine where the matrix splits and choose ql or qr iteration -c for each block, according to whether top or bottom diagonal -c element is smaller. -c - l1 = 1 - nm1 = n - 1 -c - 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 -c - 30 continue - l = l1 - lsv = l - lend = m - lendsv = lend - l1 = m + 1 - if( lend.eq.l ) - $ go to 10 -c -c scale submatrix in rows and columns l to lend -c - 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 -c -c choose between ql and qr iteration -c - if( abs( d( lend ) ).lt.abs( d( l ) ) ) then - lend = lsv - l = lendsv - end if -c - if( lend.gt.l ) then -c -c ql iteration -c -c look for small subdiagonal element. -c - 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 -c - m = lend -c - 60 continue - if( m.lt.lend ) - $ e( m ) = zero - p = d( l ) - if( m.eq.l ) - $ go to 80 -c -c if remaining matrix is 2-by-2, use dlae2 or dlaev2 -c to compute its eigensystem. -c - 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 -c$$$ call dlasr( 'r', 'v', 'b', n, 2, work( l ), -c$$$ $ work( n-1+l ), z( 1, l ), ldz ) -c -c *** New starting with version 2.5 *** -c - tst = z(l+1) - z(l+1) = c*tst - s*z(l) - z(l) = s*tst + c*z(l) -c ************************************* - 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 -c - if( jtot.eq.nmaxit ) - $ go to 140 - jtot = jtot + 1 -c -c form shift. -c - g = ( d( l+1 )-p ) / ( two*e( l ) ) - r = dlapy2( g, one ) - g = d( m ) - p + ( e( l ) / ( g+sign( r, g ) ) ) -c - s = one - c = one - p = zero -c -c inner loop -c - 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 -c -c if eigenvectors are desired, then save rotations. -c - if( icompz.gt.0 ) then - work( i ) = c - work( n-1+i ) = -s - end if -c - 70 continue -c -c if eigenvectors are desired, then apply saved rotations. -c - if( icompz.gt.0 ) then - mm = m - l + 1 -c$$$ call dlasr( 'r', 'v', 'b', n, mm, work( l ), work( n-1+l ), -c$$$ $ z( 1, l ), ldz ) -c -c *** New starting with version 2.5 *** -c - call dlasr( 'r', 'v', 'b', 1, mm, work( l ), - & work( n-1+l ), z( l ), 1 ) -c ************************************* - end if -c - d( l ) = d( l ) - p - e( l ) = g - go to 40 -c -c eigenvalue found. -c - 80 continue - d( l ) = p -c - l = l + 1 - if( l.le.lend ) - $ go to 40 - go to 140 -c - else -c -c qr iteration -c -c look for small superdiagonal element. -c - 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 -c - m = lend -c - 110 continue - if( m.gt.lend ) - $ e( m-1 ) = zero - p = d( l ) - if( m.eq.l ) - $ go to 130 -c -c if remaining matrix is 2-by-2, use dlae2 or dlaev2 -c to compute its eigensystem. -c - 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 ) -c$$$ work( m ) = c -c$$$ work( n-1+m ) = s -c$$$ call dlasr( 'r', 'v', 'f', n, 2, work( m ), -c$$$ $ work( n-1+m ), z( 1, l-1 ), ldz ) -c -c *** New starting with version 2.5 *** -c - tst = z(l) - z(l) = c*tst - s*z(l-1) - z(l-1) = s*tst + c*z(l-1) -c ************************************* - 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 -c - if( jtot.eq.nmaxit ) - $ go to 140 - jtot = jtot + 1 -c -c form shift. -c - g = ( d( l-1 )-p ) / ( two*e( l-1 ) ) - r = dlapy2( g, one ) - g = d( m ) - p + ( e( l-1 ) / ( g+sign( r, g ) ) ) -c - s = one - c = one - p = zero -c -c inner loop -c - 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 -c -c if eigenvectors are desired, then save rotations. -c - if( icompz.gt.0 ) then - work( i ) = c - work( n-1+i ) = s - end if -c - 120 continue -c -c if eigenvectors are desired, then apply saved rotations. -c - if( icompz.gt.0 ) then - mm = l - m + 1 -c$$$ call dlasr( 'r', 'v', 'f', n, mm, work( m ), work( n-1+m ), -c$$$ $ z( 1, m ), ldz ) -c -c *** New starting with version 2.5 *** -c - call dlasr( 'r', 'v', 'f', 1, mm, work( m ), work( n-1+m ), - & z( m ), 1 ) -c ************************************* - end if -c - d( l ) = d( l ) - p - e( lm1 ) = g - go to 90 -c -c eigenvalue found. -c - 130 continue - d( l ) = p -c - l = l - 1 - if( l.ge.lend ) - $ go to 90 - go to 140 -c - end if -c -c undo scaling if necessary -c - 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 -c -c check for no convergence to an eigenvalue after a total -c of n*maxit iterations. -c - 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 -c -c order eigenvalues and eigenvectors. -c - 160 continue - if( icompz.eq.0 ) then -c -c use quick sort -c - call dlasrt( 'i', n, d, info ) -c - else -c -c use selection sort to minimize swaps of eigenvectors -c - 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 -c$$$ call dswap( n, z( 1, i ), 1, z( 1, k ), 1 ) -c *** New starting with version 2.5 *** -c - p = z(k) - z(k) = z(i) - z(i) = p -c ************************************* - end if - 180 continue - end if -c - 190 continue - return -c -c %---------------% -c | End of dstqrb | -c %---------------% -c - end
--- a/libcruft/arpack/src/sgetv0.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,419 +0,0 @@ -c----------------------------------------------------------------------- -c\BeginDoc -c -c\Name: sgetv0 -c -c\Description: -c Generate a random initial residual vector for the Arnoldi process. -c Force the residual vector to be in the range of the operator OP. -c -c\Usage: -c call sgetv0 -c ( IDO, BMAT, ITRY, INITV, N, J, V, LDV, RESID, RNORM, -c IPNTR, WORKD, IERR ) -c -c\Arguments -c IDO Integer. (INPUT/OUTPUT) -c Reverse communication flag. IDO must be zero on the first -c call to sgetv0. -c ------------------------------------------------------------- -c IDO = 0: first call to the reverse communication interface -c IDO = -1: compute Y = OP * X where -c IPNTR(1) is the pointer into WORKD for X, -c IPNTR(2) is the pointer into WORKD for Y. -c This is for the initialization phase to force the -c starting vector into the range of OP. -c IDO = 2: compute Y = B * X where -c IPNTR(1) is the pointer into WORKD for X, -c IPNTR(2) is the pointer into WORKD for Y. -c IDO = 99: done -c ------------------------------------------------------------- -c -c BMAT Character*1. (INPUT) -c BMAT specifies the type of the matrix B in the (generalized) -c eigenvalue problem A*x = lambda*B*x. -c B = 'I' -> standard eigenvalue problem A*x = lambda*x -c B = 'G' -> generalized eigenvalue problem A*x = lambda*B*x -c -c ITRY Integer. (INPUT) -c ITRY counts the number of times that sgetv0 is called. -c It should be set to 1 on the initial call to sgetv0. -c -c INITV Logical variable. (INPUT) -c .TRUE. => the initial residual vector is given in RESID. -c .FALSE. => generate a random initial residual vector. -c -c N Integer. (INPUT) -c Dimension of the problem. -c -c J Integer. (INPUT) -c Index of the residual vector to be generated, with respect to -c the Arnoldi process. J > 1 in case of a "restart". -c -c V Real N by J array. (INPUT) -c The first J-1 columns of V contain the current Arnoldi basis -c if this is a "restart". -c -c LDV Integer. (INPUT) -c Leading dimension of V exactly as declared in the calling -c program. -c -c RESID Real array of length N. (INPUT/OUTPUT) -c Initial residual vector to be generated. If RESID is -c provided, force RESID into the range of the operator OP. -c -c RNORM Real scalar. (OUTPUT) -c B-norm of the generated residual. -c -c IPNTR Integer array of length 3. (OUTPUT) -c -c WORKD Real work array of length 2*N. (REVERSE COMMUNICATION). -c On exit, WORK(1:N) = B*RESID to be used in SSAITR. -c -c IERR Integer. (OUTPUT) -c = 0: Normal exit. -c = -1: Cannot generate a nontrivial restarted residual vector -c in the range of the operator OP. -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Local variables: -c xxxxxx real -c -c\References: -c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in -c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), -c pp 357-385. -c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly -c Restarted Arnoldi Iteration", Rice University Technical Report -c TR95-13, Department of Computational and Applied Mathematics. -c -c\Routines called: -c arscnd ARPACK utility routine for timing. -c svout ARPACK utility routine for vector output. -c slarnv LAPACK routine for generating a random vector. -c sgemv Level 2 BLAS routine for matrix vector multiplication. -c scopy Level 1 BLAS that copies one vector to another. -c sdot Level 1 BLAS that computes the scalar product of two vectors. -c snrm2 Level 1 BLAS that computes the norm of a vector. -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\SCCS Information: @(#) -c FILE: getv0.F SID: 2.7 DATE OF SID: 04/07/99 RELEASE: 2 -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine sgetv0 - & ( ido, bmat, itry, initv, n, j, v, ldv, resid, rnorm, - & ipntr, workd, ierr ) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - character bmat*1 - logical initv - integer ido, ierr, itry, j, ldv, n - Real - & rnorm -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - integer ipntr(3) - Real - & resid(n), v(ldv,j), workd(2*n) -c -c %------------% -c | Parameters | -c %------------% -c - Real - & one, zero - parameter (one = 1.0E+0, zero = 0.0E+0) -c -c %------------------------% -c | Local Scalars & Arrays | -c %------------------------% -c - logical first, inits, orth - integer idist, iseed(4), iter, msglvl, jj - Real - & rnorm0 - save first, iseed, inits, iter, msglvl, orth, rnorm0 -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external slarnv, svout, scopy, sgemv, arscnd -c -c %--------------------% -c | External Functions | -c %--------------------% -c - Real - & sdot, snrm2 - external sdot, snrm2 -c -c %---------------------% -c | Intrinsic Functions | -c %---------------------% -c - intrinsic abs, sqrt -c -c %-----------------% -c | Data Statements | -c %-----------------% -c - data inits /.true./ -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c -c -c %-----------------------------------% -c | Initialize the seed of the LAPACK | -c | random number generator | -c %-----------------------------------% -c - if (inits) then - iseed(1) = 1 - iseed(2) = 3 - iseed(3) = 5 - iseed(4) = 7 - inits = .false. - end if -c - if (ido .eq. 0) then -c -c %-------------------------------% -c | Initialize timing statistics | -c | & message level for debugging | -c %-------------------------------% -c - call arscnd (t0) - msglvl = mgetv0 -c - ierr = 0 - iter = 0 - first = .FALSE. - orth = .FALSE. -c -c %-----------------------------------------------------% -c | Possibly generate a random starting vector in RESID | -c | Use a LAPACK random number generator used by the | -c | matrix generation routines. | -c | idist = 1: uniform (0,1) distribution; | -c | idist = 2: uniform (-1,1) distribution; | -c | idist = 3: normal (0,1) distribution; | -c %-----------------------------------------------------% -c - if (.not.initv) then - idist = 2 - call slarnv (idist, iseed, n, resid) - end if -c -c %----------------------------------------------------------% -c | Force the starting vector into the range of OP to handle | -c | the generalized problem when B is possibly (singular). | -c %----------------------------------------------------------% -c - call arscnd (t2) - if (bmat .eq. 'G') then - nopx = nopx + 1 - ipntr(1) = 1 - ipntr(2) = n + 1 - call scopy (n, resid, 1, workd, 1) - ido = -1 - go to 9000 - end if - end if -c -c %-----------------------------------------% -c | Back from computing OP*(initial-vector) | -c %-----------------------------------------% -c - if (first) go to 20 -c -c %-----------------------------------------------% -c | Back from computing B*(orthogonalized-vector) | -c %-----------------------------------------------% -c - if (orth) go to 40 -c - if (bmat .eq. 'G') then - call arscnd (t3) - tmvopx = tmvopx + (t3 - t2) - end if -c -c %------------------------------------------------------% -c | Starting vector is now in the range of OP; r = OP*r; | -c | Compute B-norm of starting vector. | -c %------------------------------------------------------% -c - call arscnd (t2) - first = .TRUE. - if (bmat .eq. 'G') then - nbx = nbx + 1 - call scopy (n, workd(n+1), 1, resid, 1) - ipntr(1) = n + 1 - ipntr(2) = 1 - ido = 2 - go to 9000 - else if (bmat .eq. 'I') then - call scopy (n, resid, 1, workd, 1) - end if -c - 20 continue -c - if (bmat .eq. 'G') then - call arscnd (t3) - tmvbx = tmvbx + (t3 - t2) - end if -c - first = .FALSE. - if (bmat .eq. 'G') then - rnorm0 = sdot (n, resid, 1, workd, 1) - rnorm0 = sqrt(abs(rnorm0)) - else if (bmat .eq. 'I') then - rnorm0 = snrm2(n, resid, 1) - end if - rnorm = rnorm0 -c -c %---------------------------------------------% -c | Exit if this is the very first Arnoldi step | -c %---------------------------------------------% -c - if (j .eq. 1) go to 50 -c -c %---------------------------------------------------------------- -c | Otherwise need to B-orthogonalize the starting vector against | -c | the current Arnoldi basis using Gram-Schmidt with iter. ref. | -c | This is the case where an invariant subspace is encountered | -c | in the middle of the Arnoldi factorization. | -c | | -c | s = V^{T}*B*r; r = r - V*s; | -c | | -c | Stopping criteria used for iter. ref. is discussed in | -c | Parlett's book, page 107 and in Gragg & Reichel TOMS paper. | -c %---------------------------------------------------------------% -c - orth = .TRUE. - 30 continue -c - call sgemv ('T', n, j-1, one, v, ldv, workd, 1, - & zero, workd(n+1), 1) - call sgemv ('N', n, j-1, -one, v, ldv, workd(n+1), 1, - & one, resid, 1) -c -c %----------------------------------------------------------% -c | Compute the B-norm of the orthogonalized starting vector | -c %----------------------------------------------------------% -c - call arscnd (t2) - if (bmat .eq. 'G') then - nbx = nbx + 1 - call scopy (n, resid, 1, workd(n+1), 1) - ipntr(1) = n + 1 - ipntr(2) = 1 - ido = 2 - go to 9000 - else if (bmat .eq. 'I') then - call scopy (n, resid, 1, workd, 1) - end if -c - 40 continue -c - if (bmat .eq. 'G') then - call arscnd (t3) - tmvbx = tmvbx + (t3 - t2) - end if -c - if (bmat .eq. 'G') then - rnorm = sdot (n, resid, 1, workd, 1) - rnorm = sqrt(abs(rnorm)) - else if (bmat .eq. 'I') then - rnorm = snrm2(n, resid, 1) - end if -c -c %--------------------------------------% -c | Check for further orthogonalization. | -c %--------------------------------------% -c - if (msglvl .gt. 2) then - call svout (logfil, 1, rnorm0, ndigit, - & '_getv0: re-orthonalization ; rnorm0 is') - call svout (logfil, 1, rnorm, ndigit, - & '_getv0: re-orthonalization ; rnorm is') - end if -c - if (rnorm .gt. 0.717*rnorm0) go to 50 -c - iter = iter + 1 - if (iter .le. 5) then -c -c %-----------------------------------% -c | Perform iterative refinement step | -c %-----------------------------------% -c - rnorm0 = rnorm - go to 30 - else -c -c %------------------------------------% -c | Iterative refinement step "failed" | -c %------------------------------------% -c - do 45 jj = 1, n - resid(jj) = zero - 45 continue - rnorm = zero - ierr = -1 - end if -c - 50 continue -c - if (msglvl .gt. 0) then - call svout (logfil, 1, rnorm, ndigit, - & '_getv0: B-norm of initial / restarted starting vector') - end if - if (msglvl .gt. 3) then - call svout (logfil, n, resid, ndigit, - & '_getv0: initial / restarted starting vector') - end if - ido = 99 -c - call arscnd (t1) - tgetv0 = tgetv0 + (t1 - t0) -c - 9000 continue - return -c -c %---------------% -c | End of sgetv0 | -c %---------------% -c - end
--- a/libcruft/arpack/src/slaqrb.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,521 +0,0 @@ -c----------------------------------------------------------------------- -c\BeginDoc -c -c\Name: slaqrb -c -c\Description: -c Compute the eigenvalues and the Schur decomposition of an upper -c Hessenberg submatrix in rows and columns ILO to IHI. Only the -c last component of the Schur vectors are computed. -c -c This is mostly a modification of the LAPACK routine slahqr. -c -c\Usage: -c call slaqrb -c ( WANTT, N, ILO, IHI, H, LDH, WR, WI, Z, INFO ) -c -c\Arguments -c WANTT Logical variable. (INPUT) -c = .TRUE. : the full Schur form T is required; -c = .FALSE.: only eigenvalues are required. -c -c N Integer. (INPUT) -c The order of the matrix H. N >= 0. -c -c ILO Integer. (INPUT) -c IHI Integer. (INPUT) -c It is assumed that H is already upper quasi-triangular in -c rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless -c ILO = 1). SLAQRB works primarily with the Hessenberg -c submatrix in rows and columns ILO to IHI, but applies -c transformations to all of H if WANTT is .TRUE.. -c 1 <= ILO <= max(1,IHI); IHI <= N. -c -c H Real array, dimension (LDH,N). (INPUT/OUTPUT) -c On entry, the upper Hessenberg matrix H. -c On exit, if WANTT is .TRUE., H is upper quasi-triangular in -c rows and columns ILO:IHI, with any 2-by-2 diagonal blocks in -c standard form. If WANTT is .FALSE., the contents of H are -c unspecified on exit. -c -c LDH Integer. (INPUT) -c The leading dimension of the array H. LDH >= max(1,N). -c -c WR Real array, dimension (N). (OUTPUT) -c WI Real array, dimension (N). (OUTPUT) -c The real and imaginary parts, respectively, of the computed -c eigenvalues ILO to IHI are stored in the corresponding -c elements of WR and WI. If two eigenvalues are computed as a -c complex conjugate pair, they are stored in consecutive -c elements of WR and WI, say the i-th and (i+1)th, with -c WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the -c eigenvalues are stored in the same order as on the diagonal -c of the Schur form returned in H, with WR(i) = H(i,i), and, if -c H(i:i+1,i:i+1) is a 2-by-2 diagonal block, -c WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i). -c -c Z Real array, dimension (N). (OUTPUT) -c On exit Z contains the last components of the Schur vectors. -c -c INFO Integer. (OUPUT) -c = 0: successful exit -c > 0: SLAQRB failed to compute all the eigenvalues ILO to IHI -c in a total of 30*(IHI-ILO+1) iterations; if INFO = i, -c elements i+1:ihi of WR and WI contain those eigenvalues -c which have been successfully computed. -c -c\Remarks -c 1. None. -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Local variables: -c xxxxxx real -c -c\Routines called: -c slabad LAPACK routine that computes machine constants. -c slamch LAPACK routine that determines machine constants. -c slanhs LAPACK routine that computes various norms of a matrix. -c slanv2 LAPACK routine that computes the Schur factorization of -c 2 by 2 nonsymmetric matrix in standard form. -c slarfg LAPACK Householder reflection construction routine. -c scopy Level 1 BLAS that copies one vector to another. -c srot Level 1 BLAS that applies a rotation to a 2 by 2 matrix. - -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\Revision history: -c xx/xx/92: Version ' 2.4' -c Modified from the LAPACK routine slahqr so that only the -c last component of the Schur vectors are computed. -c -c\SCCS Information: @(#) -c FILE: laqrb.F SID: 2.2 DATE OF SID: 8/27/96 RELEASE: 2 -c -c\Remarks -c 1. None -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine slaqrb ( wantt, n, ilo, ihi, h, ldh, wr, wi, - & z, info ) -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - logical wantt - integer ihi, ilo, info, ldh, n -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - Real - & h( ldh, * ), wi( * ), wr( * ), z( * ) -c -c %------------% -c | Parameters | -c %------------% -c - Real - & zero, one, dat1, dat2 - parameter (zero = 0.0E+0, one = 1.0E+0, dat1 = 7.5E-1, - & dat2 = -4.375E-1) -c -c %------------------------% -c | Local Scalars & Arrays | -c %------------------------% -c - integer i, i1, i2, itn, its, j, k, l, m, nh, nr - Real - & cs, h00, h10, h11, h12, h21, h22, h33, h33s, - & h43h34, h44, h44s, ovfl, s, smlnum, sn, sum, - & t1, t2, t3, tst1, ulp, unfl, v1, v2, v3 - Real - & v( 3 ), work( 1 ) -c -c %--------------------% -c | External Functions | -c %--------------------% -c - Real - & slamch, slanhs - external slamch, slanhs -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external scopy, slabad, slanv2, slarfg, srot -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c - info = 0 -c -c %--------------------------% -c | Quick return if possible | -c %--------------------------% -c - if( n.eq.0 ) - & return - if( ilo.eq.ihi ) then - wr( ilo ) = h( ilo, ilo ) - wi( ilo ) = zero - return - end if -c -c %---------------------------------------------% -c | Initialize the vector of last components of | -c | the Schur vectors for accumulation. | -c %---------------------------------------------% -c - do 5 j = 1, n-1 - z(j) = zero - 5 continue - z(n) = one -c - nh = ihi - ilo + 1 -c -c %-------------------------------------------------------------% -c | Set machine-dependent constants for the stopping criterion. | -c | If norm(H) <= sqrt(OVFL), overflow should not occur. | -c %-------------------------------------------------------------% -c - unfl = slamch( 'safe minimum' ) - ovfl = one / unfl - call slabad( unfl, ovfl ) - ulp = slamch( 'precision' ) - smlnum = unfl*( nh / ulp ) -c -c %---------------------------------------------------------------% -c | I1 and I2 are the indices of the first row and last column | -c | of H to which transformations must be applied. If eigenvalues | -c | only are computed, I1 and I2 are set inside the main loop. | -c | Zero out H(J+2,J) = ZERO for J=1:N if WANTT = .TRUE. | -c | else H(J+2,J) for J=ILO:IHI-ILO-1 if WANTT = .FALSE. | -c %---------------------------------------------------------------% -c - if( wantt ) then - i1 = 1 - i2 = n - do 8 i=1,i2-2 - h(i1+i+1,i) = zero - 8 continue - else - do 9 i=1, ihi-ilo-1 - h(ilo+i+1,ilo+i-1) = zero - 9 continue - end if -c -c %---------------------------------------------------% -c | ITN is the total number of QR iterations allowed. | -c %---------------------------------------------------% -c - itn = 30*nh -c -c ------------------------------------------------------------------ -c The main loop begins here. I is the loop index and decreases from -c IHI to ILO in steps of 1 or 2. Each iteration of the loop works -c with the active submatrix in rows and columns L to I. -c Eigenvalues I+1 to IHI have already converged. Either L = ILO or -c H(L,L-1) is negligible so that the matrix splits. -c ------------------------------------------------------------------ -c - i = ihi - 10 continue - l = ilo - if( i.lt.ilo ) - & go to 150 - -c %--------------------------------------------------------------% -c | Perform QR iterations on rows and columns ILO to I until a | -c | submatrix of order 1 or 2 splits off at the bottom because a | -c | subdiagonal element has become negligible. | -c %--------------------------------------------------------------% - - do 130 its = 0, itn -c -c %----------------------------------------------% -c | Look for a single small subdiagonal element. | -c %----------------------------------------------% -c - do 20 k = i, l + 1, -1 - tst1 = abs( h( k-1, k-1 ) ) + abs( h( k, k ) ) - if( tst1.eq.zero ) - & tst1 = slanhs( '1', i-l+1, h( l, l ), ldh, work ) - if( abs( h( k, k-1 ) ).le.max( ulp*tst1, smlnum ) ) - & go to 30 - 20 continue - 30 continue - l = k - if( l.gt.ilo ) then -c -c %------------------------% -c | H(L,L-1) is negligible | -c %------------------------% -c - h( l, l-1 ) = zero - end if -c -c %-------------------------------------------------------------% -c | Exit from loop if a submatrix of order 1 or 2 has split off | -c %-------------------------------------------------------------% -c - if( l.ge.i-1 ) - & go to 140 -c -c %---------------------------------------------------------% -c | Now the active submatrix is in rows and columns L to I. | -c | If eigenvalues only are being computed, only the active | -c | submatrix need be transformed. | -c %---------------------------------------------------------% -c - if( .not.wantt ) then - i1 = l - i2 = i - end if -c - if( its.eq.10 .or. its.eq.20 ) then -c -c %-------------------% -c | Exceptional shift | -c %-------------------% -c - s = abs( h( i, i-1 ) ) + abs( h( i-1, i-2 ) ) - h44 = dat1*s - h33 = h44 - h43h34 = dat2*s*s -c - else -c -c %-----------------------------------------% -c | Prepare to use Wilkinson's double shift | -c %-----------------------------------------% -c - h44 = h( i, i ) - h33 = h( i-1, i-1 ) - h43h34 = h( i, i-1 )*h( i-1, i ) - end if -c -c %-----------------------------------------------------% -c | Look for two consecutive small subdiagonal elements | -c %-----------------------------------------------------% -c - do 40 m = i - 2, l, -1 -c -c %---------------------------------------------------------% -c | Determine the effect of starting the double-shift QR | -c | iteration at row M, and see if this would make H(M,M-1) | -c | negligible. | -c %---------------------------------------------------------% -c - h11 = h( m, m ) - h22 = h( m+1, m+1 ) - h21 = h( m+1, m ) - h12 = h( m, m+1 ) - h44s = h44 - h11 - h33s = h33 - h11 - v1 = ( h33s*h44s-h43h34 ) / h21 + h12 - v2 = h22 - h11 - h33s - h44s - v3 = h( m+2, m+1 ) - s = abs( v1 ) + abs( v2 ) + abs( v3 ) - v1 = v1 / s - v2 = v2 / s - v3 = v3 / s - v( 1 ) = v1 - v( 2 ) = v2 - v( 3 ) = v3 - if( m.eq.l ) - & go to 50 - h00 = h( m-1, m-1 ) - h10 = h( m, m-1 ) - tst1 = abs( v1 )*( abs( h00 )+abs( h11 )+abs( h22 ) ) - if( abs( h10 )*( abs( v2 )+abs( v3 ) ).le.ulp*tst1 ) - & go to 50 - 40 continue - 50 continue -c -c %----------------------% -c | Double-shift QR step | -c %----------------------% -c - do 120 k = m, i - 1 -c -c ------------------------------------------------------------ -c The first iteration of this loop determines a reflection G -c from the vector V and applies it from left and right to H, -c thus creating a nonzero bulge below the subdiagonal. -c -c Each subsequent iteration determines a reflection G to -c restore the Hessenberg form in the (K-1)th column, and thus -c chases the bulge one step toward the bottom of the active -c submatrix. NR is the order of G. -c ------------------------------------------------------------ -c - 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 -c -c %------------------------------------------------% -c | Apply G from the left to transform the rows of | -c | the matrix in columns K to I2. | -c %------------------------------------------------% -c - do 60 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 - 60 continue -c -c %----------------------------------------------------% -c | Apply G from the right to transform the columns of | -c | the matrix in rows I1 to min(K+3,I). | -c %----------------------------------------------------% -c - do 70 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 - 70 continue -c -c %----------------------------------% -c | Accumulate transformations for Z | -c %----------------------------------% -c - sum = z( k ) + v2*z( k+1 ) + v3*z( k+2 ) - z( k ) = z( k ) - sum*t1 - z( k+1 ) = z( k+1 ) - sum*t2 - z( k+2 ) = z( k+2 ) - sum*t3 - - else if( nr.eq.2 ) then -c -c %------------------------------------------------% -c | Apply G from the left to transform the rows of | -c | the matrix in columns K to I2. | -c %------------------------------------------------% -c - do 90 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 - 90 continue -c -c %----------------------------------------------------% -c | Apply G from the right to transform the columns of | -c | the matrix in rows I1 to min(K+3,I). | -c %----------------------------------------------------% -c - do 100 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 - 100 continue -c -c %----------------------------------% -c | Accumulate transformations for Z | -c %----------------------------------% -c - sum = z( k ) + v2*z( k+1 ) - z( k ) = z( k ) - sum*t1 - z( k+1 ) = z( k+1 ) - sum*t2 - end if - 120 continue - - 130 continue -c -c %-------------------------------------------------------% -c | Failure to converge in remaining number of iterations | -c %-------------------------------------------------------% -c - info = i - return - - 140 continue - - if( l.eq.i ) then -c -c %------------------------------------------------------% -c | H(I,I-1) is negligible: one eigenvalue has converged | -c %------------------------------------------------------% -c - wr( i ) = h( i, i ) - wi( i ) = zero - - else if( l.eq.i-1 ) then -c -c %--------------------------------------------------------% -c | H(I-1,I-2) is negligible; | -c | a pair of eigenvalues have converged. | -c | | -c | Transform the 2-by-2 submatrix to standard Schur form, | -c | and compute and store the eigenvalues. | -c %--------------------------------------------------------% -c - 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 -c -c %-----------------------------------------------------% -c | Apply the transformation to the rest of H and to Z, | -c | as required. | -c %-----------------------------------------------------% -c - 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 ) - sum = cs*z( i-1 ) + sn*z( i ) - z( i ) = cs*z( i ) - sn*z( i-1 ) - z( i-1 ) = sum - end if - end if -c -c %---------------------------------------------------------% -c | Decrement number of remaining iterations, and return to | -c | start of the main loop with new value of I. | -c %---------------------------------------------------------% -c - itn = itn - its - i = l - 1 - go to 10 - - 150 continue - return -c -c %---------------% -c | End of slaqrb | -c %---------------% -c - end
--- a/libcruft/arpack/src/snaitr.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,840 +0,0 @@ -c----------------------------------------------------------------------- -c\BeginDoc -c -c\Name: snaitr -c -c\Description: -c Reverse communication interface for applying NP additional steps to -c a K step nonsymmetric Arnoldi factorization. -c -c Input: OP*V_{k} - V_{k}*H = r_{k}*e_{k}^T -c -c with (V_{k}^T)*B*V_{k} = I, (V_{k}^T)*B*r_{k} = 0. -c -c Output: OP*V_{k+p} - V_{k+p}*H = r_{k+p}*e_{k+p}^T -c -c with (V_{k+p}^T)*B*V_{k+p} = I, (V_{k+p}^T)*B*r_{k+p} = 0. -c -c where OP and B are as in snaupd. The B-norm of r_{k+p} is also -c computed and returned. -c -c\Usage: -c call snaitr -c ( IDO, BMAT, N, K, NP, NB, RESID, RNORM, V, LDV, H, LDH, -c IPNTR, WORKD, INFO ) -c -c\Arguments -c IDO Integer. (INPUT/OUTPUT) -c Reverse communication flag. -c ------------------------------------------------------------- -c IDO = 0: first call to the reverse communication interface -c IDO = -1: compute Y = OP * X where -c IPNTR(1) is the pointer into WORK for X, -c IPNTR(2) is the pointer into WORK for Y. -c This is for the restart phase to force the new -c starting vector into the range of OP. -c IDO = 1: compute Y = OP * X where -c IPNTR(1) is the pointer into WORK for X, -c IPNTR(2) is the pointer into WORK for Y, -c IPNTR(3) is the pointer into WORK for B * X. -c IDO = 2: compute Y = B * X where -c IPNTR(1) is the pointer into WORK for X, -c IPNTR(2) is the pointer into WORK for Y. -c IDO = 99: done -c ------------------------------------------------------------- -c When the routine is used in the "shift-and-invert" mode, the -c vector B * Q is already available and do not need to be -c recompute in forming OP * Q. -c -c BMAT Character*1. (INPUT) -c BMAT specifies the type of the matrix B that defines the -c semi-inner product for the operator OP. See snaupd. -c B = 'I' -> standard eigenvalue problem A*x = lambda*x -c B = 'G' -> generalized eigenvalue problem A*x = lambda*M**x -c -c N Integer. (INPUT) -c Dimension of the eigenproblem. -c -c K Integer. (INPUT) -c Current size of V and H. -c -c NP Integer. (INPUT) -c Number of additional Arnoldi steps to take. -c -c NB Integer. (INPUT) -c Blocksize to be used in the recurrence. -c Only work for NB = 1 right now. The goal is to have a -c program that implement both the block and non-block method. -c -c RESID Real array of length N. (INPUT/OUTPUT) -c On INPUT: RESID contains the residual vector r_{k}. -c On OUTPUT: RESID contains the residual vector r_{k+p}. -c -c RNORM Real scalar. (INPUT/OUTPUT) -c B-norm of the starting residual on input. -c B-norm of the updated residual r_{k+p} on output. -c -c V Real N by K+NP array. (INPUT/OUTPUT) -c On INPUT: V contains the Arnoldi vectors in the first K -c columns. -c On OUTPUT: V contains the new NP Arnoldi vectors in the next -c NP columns. The first K columns are unchanged. -c -c LDV Integer. (INPUT) -c Leading dimension of V exactly as declared in the calling -c program. -c -c H Real (K+NP) by (K+NP) array. (INPUT/OUTPUT) -c H is used to store the generated upper Hessenberg matrix. -c -c LDH Integer. (INPUT) -c Leading dimension of H exactly as declared in the calling -c program. -c -c IPNTR Integer array of length 3. (OUTPUT) -c Pointer to mark the starting locations in the WORK for -c vectors used by the Arnoldi iteration. -c ------------------------------------------------------------- -c IPNTR(1): pointer to the current operand vector X. -c IPNTR(2): pointer to the current result vector Y. -c IPNTR(3): pointer to the vector B * X when used in the -c shift-and-invert mode. X is the current operand. -c ------------------------------------------------------------- -c -c WORKD Real work array of length 3*N. (REVERSE COMMUNICATION) -c Distributed array to be used in the basic Arnoldi iteration -c for reverse communication. The calling program should not -c use WORKD as temporary workspace during the iteration !!!!!! -c On input, WORKD(1:N) = B*RESID and is used to save some -c computation at the first step. -c -c INFO Integer. (OUTPUT) -c = 0: Normal exit. -c > 0: Size of the spanning invariant subspace of OP found. -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Local variables: -c xxxxxx real -c -c\References: -c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in -c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), -c pp 357-385. -c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly -c Restarted Arnoldi Iteration", Rice University Technical Report -c TR95-13, Department of Computational and Applied Mathematics. -c -c\Routines called: -c sgetv0 ARPACK routine to generate the initial vector. -c ivout ARPACK utility routine that prints integers. -c arscnd ARPACK utility routine for timing. -c smout ARPACK utility routine that prints matrices -c svout ARPACK utility routine that prints vectors. -c slabad LAPACK routine that computes machine constants. -c slamch LAPACK routine that determines machine constants. -c slascl LAPACK routine for careful scaling of a matrix. -c slanhs LAPACK routine that computes various norms of a matrix. -c sgemv Level 2 BLAS routine for matrix vector multiplication. -c saxpy Level 1 BLAS that computes a vector triad. -c sscal Level 1 BLAS that scales a vector. -c scopy Level 1 BLAS that copies one vector to another . -c sdot Level 1 BLAS that computes the scalar product of two vectors. -c snrm2 Level 1 BLAS that computes the norm of a vector. -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\Revision history: -c xx/xx/92: Version ' 2.4' -c -c\SCCS Information: @(#) -c FILE: naitr.F SID: 2.4 DATE OF SID: 8/27/96 RELEASE: 2 -c -c\Remarks -c The algorithm implemented is: -c -c restart = .false. -c Given V_{k} = [v_{1}, ..., v_{k}], r_{k}; -c r_{k} contains the initial residual vector even for k = 0; -c Also assume that rnorm = || B*r_{k} || and B*r_{k} are already -c computed by the calling program. -c -c betaj = rnorm ; p_{k+1} = B*r_{k} ; -c For j = k+1, ..., k+np Do -c 1) if ( betaj < tol ) stop or restart depending on j. -c ( At present tol is zero ) -c if ( restart ) generate a new starting vector. -c 2) v_{j} = r(j-1)/betaj; V_{j} = [V_{j-1}, v_{j}]; -c p_{j} = p_{j}/betaj -c 3) r_{j} = OP*v_{j} where OP is defined as in snaupd -c For shift-invert mode p_{j} = B*v_{j} is already available. -c wnorm = || OP*v_{j} || -c 4) Compute the j-th step residual vector. -c w_{j} = V_{j}^T * B * OP * v_{j} -c r_{j} = OP*v_{j} - V_{j} * w_{j} -c H(:,j) = w_{j}; -c H(j,j-1) = rnorm -c rnorm = || r_(j) || -c If (rnorm > 0.717*wnorm) accept step and go back to 1) -c 5) Re-orthogonalization step: -c s = V_{j}'*B*r_{j} -c r_{j} = r_{j} - V_{j}*s; rnorm1 = || r_{j} || -c alphaj = alphaj + s_{j}; -c 6) Iterative refinement step: -c If (rnorm1 > 0.717*rnorm) then -c rnorm = rnorm1 -c accept step and go back to 1) -c Else -c rnorm = rnorm1 -c If this is the first time in step 6), go to 5) -c Else r_{j} lies in the span of V_{j} numerically. -c Set r_{j} = 0 and rnorm = 0; go to 1) -c EndIf -c End Do -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine snaitr - & (ido, bmat, n, k, np, nb, resid, rnorm, v, ldv, h, ldh, - & ipntr, workd, info) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - character bmat*1 - integer ido, info, k, ldh, ldv, n, nb, np - Real - & rnorm -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - integer ipntr(3) - Real - & h(ldh,k+np), resid(n), v(ldv,k+np), workd(3*n) -c -c %------------% -c | Parameters | -c %------------% -c - Real - & one, zero - parameter (one = 1.0E+0, zero = 0.0E+0) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - logical first, orth1, orth2, rstart, step3, step4 - integer ierr, i, infol, ipj, irj, ivj, iter, itry, j, msglvl, - & jj - Real - & betaj, ovfl, temp1, rnorm1, smlnum, tst1, ulp, unfl, - & wnorm - save first, orth1, orth2, rstart, step3, step4, - & ierr, ipj, irj, ivj, iter, itry, j, msglvl, ovfl, - & betaj, rnorm1, smlnum, ulp, unfl, wnorm -c -c %-----------------------% -c | Local Array Arguments | -c %-----------------------% -c - Real - & xtemp(2) -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external saxpy, scopy, sscal, sgemv, sgetv0, slabad, - & svout, smout, ivout, arscnd -c -c %--------------------% -c | External Functions | -c %--------------------% -c - Real - & sdot, snrm2, slanhs, slamch - external sdot, snrm2, slanhs, slamch -c -c %---------------------% -c | Intrinsic Functions | -c %---------------------% -c - intrinsic abs, sqrt -c -c %-----------------% -c | Data statements | -c %-----------------% -c - data first / .true. / -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c - if (first) then -c -c %-----------------------------------------% -c | Set machine-dependent constants for the | -c | the splitting and deflation criterion. | -c | If norm(H) <= sqrt(OVFL), | -c | overflow should not occur. | -c | REFERENCE: LAPACK subroutine slahqr | -c %-----------------------------------------% -c - unfl = slamch( 'safe minimum' ) - ovfl = one / unfl - call slabad( unfl, ovfl ) - ulp = slamch( 'precision' ) - smlnum = unfl*( n / ulp ) - first = .false. - end if -c - if (ido .eq. 0) then -c -c %-------------------------------% -c | Initialize timing statistics | -c | & message level for debugging | -c %-------------------------------% -c - call arscnd (t0) - msglvl = mnaitr -c -c %------------------------------% -c | Initial call to this routine | -c %------------------------------% -c - info = 0 - step3 = .false. - step4 = .false. - rstart = .false. - orth1 = .false. - orth2 = .false. - j = k + 1 - ipj = 1 - irj = ipj + n - ivj = irj + n - end if -c -c %-------------------------------------------------% -c | When in reverse communication mode one of: | -c | STEP3, STEP4, ORTH1, ORTH2, RSTART | -c | will be .true. when .... | -c | STEP3: return from computing OP*v_{j}. | -c | STEP4: return from computing B-norm of OP*v_{j} | -c | ORTH1: return from computing B-norm of r_{j+1} | -c | ORTH2: return from computing B-norm of | -c | correction to the residual vector. | -c | RSTART: return from OP computations needed by | -c | sgetv0. | -c %-------------------------------------------------% -c - if (step3) go to 50 - if (step4) go to 60 - if (orth1) go to 70 - if (orth2) go to 90 - if (rstart) go to 30 -c -c %-----------------------------% -c | Else this is the first step | -c %-----------------------------% -c -c %--------------------------------------------------------------% -c | | -c | A R N O L D I I T E R A T I O N L O O P | -c | | -c | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) | -c %--------------------------------------------------------------% - - 1000 continue -c - if (msglvl .gt. 1) then - call ivout (logfil, 1, j, ndigit, - & '_naitr: generating Arnoldi vector number') - call svout (logfil, 1, rnorm, ndigit, - & '_naitr: B-norm of the current residual is') - end if -c -c %---------------------------------------------------% -c | STEP 1: Check if the B norm of j-th residual | -c | vector is zero. Equivalent to determing whether | -c | an exact j-step Arnoldi factorization is present. | -c %---------------------------------------------------% -c - betaj = rnorm - if (rnorm .gt. zero) go to 40 -c -c %---------------------------------------------------% -c | Invariant subspace found, generate a new starting | -c | vector which is orthogonal to the current Arnoldi | -c | basis and continue the iteration. | -c %---------------------------------------------------% -c - if (msglvl .gt. 0) then - call ivout (logfil, 1, j, ndigit, - & '_naitr: ****** RESTART AT STEP ******') - end if -c -c %---------------------------------------------% -c | ITRY is the loop variable that controls the | -c | maximum amount of times that a restart is | -c | attempted. NRSTRT is used by stat.h | -c %---------------------------------------------% -c - betaj = zero - nrstrt = nrstrt + 1 - itry = 1 - 20 continue - rstart = .true. - ido = 0 - 30 continue -c -c %--------------------------------------% -c | If in reverse communication mode and | -c | RSTART = .true. flow returns here. | -c %--------------------------------------% -c - call sgetv0 (ido, bmat, itry, .false., n, j, v, ldv, - & resid, rnorm, ipntr, workd, ierr) - if (ido .ne. 99) go to 9000 - if (ierr .lt. 0) then - itry = itry + 1 - if (itry .le. 3) go to 20 -c -c %------------------------------------------------% -c | Give up after several restart attempts. | -c | Set INFO to the size of the invariant subspace | -c | which spans OP and exit. | -c %------------------------------------------------% -c - info = j - 1 - call arscnd (t1) - tnaitr = tnaitr + (t1 - t0) - ido = 99 - go to 9000 - end if -c - 40 continue -c -c %---------------------------------------------------------% -c | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm | -c | Note that p_{j} = B*r_{j-1}. In order to avoid overflow | -c | when reciprocating a small RNORM, test against lower | -c | machine bound. | -c %---------------------------------------------------------% -c - call scopy (n, resid, 1, v(1,j), 1) - if (rnorm .ge. unfl) then - temp1 = one / rnorm - call sscal (n, temp1, v(1,j), 1) - call sscal (n, temp1, workd(ipj), 1) - else -c -c %-----------------------------------------% -c | To scale both v_{j} and p_{j} carefully | -c | use LAPACK routine SLASCL | -c %-----------------------------------------% -c - call slascl ('General', i, i, rnorm, one, n, 1, - & v(1,j), n, infol) - call slascl ('General', i, i, rnorm, one, n, 1, - & workd(ipj), n, infol) - end if -c -c %------------------------------------------------------% -c | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} | -c | Note that this is not quite yet r_{j}. See STEP 4 | -c %------------------------------------------------------% -c - step3 = .true. - nopx = nopx + 1 - call arscnd (t2) - call scopy (n, v(1,j), 1, workd(ivj), 1) - ipntr(1) = ivj - ipntr(2) = irj - ipntr(3) = ipj - ido = 1 -c -c %-----------------------------------% -c | Exit in order to compute OP*v_{j} | -c %-----------------------------------% -c - go to 9000 - 50 continue -c -c %----------------------------------% -c | Back from reverse communication; | -c | WORKD(IRJ:IRJ+N-1) := OP*v_{j} | -c | if step3 = .true. | -c %----------------------------------% -c - call arscnd (t3) - tmvopx = tmvopx + (t3 - t2) - - step3 = .false. -c -c %------------------------------------------% -c | Put another copy of OP*v_{j} into RESID. | -c %------------------------------------------% -c - call scopy (n, workd(irj), 1, resid, 1) -c -c %---------------------------------------% -c | STEP 4: Finish extending the Arnoldi | -c | factorization to length j. | -c %---------------------------------------% -c - call arscnd (t2) - if (bmat .eq. 'G') then - nbx = nbx + 1 - step4 = .true. - ipntr(1) = irj - ipntr(2) = ipj - ido = 2 -c -c %-------------------------------------% -c | Exit in order to compute B*OP*v_{j} | -c %-------------------------------------% -c - go to 9000 - else if (bmat .eq. 'I') then - call scopy (n, resid, 1, workd(ipj), 1) - end if - 60 continue -c -c %----------------------------------% -c | Back from reverse communication; | -c | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j} | -c | if step4 = .true. | -c %----------------------------------% -c - if (bmat .eq. 'G') then - call arscnd (t3) - tmvbx = tmvbx + (t3 - t2) - end if -c - step4 = .false. -c -c %-------------------------------------% -c | The following is needed for STEP 5. | -c | Compute the B-norm of OP*v_{j}. | -c %-------------------------------------% -c - if (bmat .eq. 'G') then - wnorm = sdot (n, resid, 1, workd(ipj), 1) - wnorm = sqrt(abs(wnorm)) - else if (bmat .eq. 'I') then - wnorm = snrm2(n, resid, 1) - end if -c -c %-----------------------------------------% -c | Compute the j-th residual corresponding | -c | to the j step factorization. | -c | Use Classical Gram Schmidt and compute: | -c | w_{j} <- V_{j}^T * B * OP * v_{j} | -c | r_{j} <- OP*v_{j} - V_{j} * w_{j} | -c %-----------------------------------------% -c -c -c %------------------------------------------% -c | Compute the j Fourier coefficients w_{j} | -c | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. | -c %------------------------------------------% -c - call sgemv ('T', n, j, one, v, ldv, workd(ipj), 1, - & zero, h(1,j), 1) -c -c %--------------------------------------% -c | Orthogonalize r_{j} against V_{j}. | -c | RESID contains OP*v_{j}. See STEP 3. | -c %--------------------------------------% -c - call sgemv ('N', n, j, -one, v, ldv, h(1,j), 1, - & one, resid, 1) -c - if (j .gt. 1) h(j,j-1) = betaj -c - call arscnd (t4) -c - orth1 = .true. -c - call arscnd (t2) - if (bmat .eq. 'G') then - nbx = nbx + 1 - call scopy (n, resid, 1, workd(irj), 1) - ipntr(1) = irj - ipntr(2) = ipj - ido = 2 -c -c %----------------------------------% -c | Exit in order to compute B*r_{j} | -c %----------------------------------% -c - go to 9000 - else if (bmat .eq. 'I') then - call scopy (n, resid, 1, workd(ipj), 1) - end if - 70 continue -c -c %---------------------------------------------------% -c | Back from reverse communication if ORTH1 = .true. | -c | WORKD(IPJ:IPJ+N-1) := B*r_{j}. | -c %---------------------------------------------------% -c - if (bmat .eq. 'G') then - call arscnd (t3) - tmvbx = tmvbx + (t3 - t2) - end if -c - orth1 = .false. -c -c %------------------------------% -c | Compute the B-norm of r_{j}. | -c %------------------------------% -c - if (bmat .eq. 'G') then - rnorm = sdot (n, resid, 1, workd(ipj), 1) - rnorm = sqrt(abs(rnorm)) - else if (bmat .eq. 'I') then - rnorm = snrm2(n, resid, 1) - end if -c -c %-----------------------------------------------------------% -c | STEP 5: Re-orthogonalization / Iterative refinement phase | -c | Maximum NITER_ITREF tries. | -c | | -c | s = V_{j}^T * B * r_{j} | -c | r_{j} = r_{j} - V_{j}*s | -c | alphaj = alphaj + s_{j} | -c | | -c | The stopping criteria used for iterative refinement is | -c | discussed in Parlett's book SEP, page 107 and in Gragg & | -c | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. | -c | Determine if we need to correct the residual. The goal is | -c | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || | -c | The following test determines whether the sine of the | -c | angle between OP*x and the computed residual is less | -c | than or equal to 0.717. | -c %-----------------------------------------------------------% -c - if (rnorm .gt. 0.717*wnorm) go to 100 - iter = 0 - nrorth = nrorth + 1 -c -c %---------------------------------------------------% -c | Enter the Iterative refinement phase. If further | -c | refinement is necessary, loop back here. The loop | -c | variable is ITER. Perform a step of Classical | -c | Gram-Schmidt using all the Arnoldi vectors V_{j} | -c %---------------------------------------------------% -c - 80 continue -c - if (msglvl .gt. 2) then - xtemp(1) = wnorm - xtemp(2) = rnorm - call svout (logfil, 2, xtemp, ndigit, - & '_naitr: re-orthonalization; wnorm and rnorm are') - call svout (logfil, j, h(1,j), ndigit, - & '_naitr: j-th column of H') - end if -c -c %----------------------------------------------------% -c | Compute V_{j}^T * B * r_{j}. | -c | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). | -c %----------------------------------------------------% -c - call sgemv ('T', n, j, one, v, ldv, workd(ipj), 1, - & zero, workd(irj), 1) -c -c %---------------------------------------------% -c | Compute the correction to the residual: | -c | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). | -c | The correction to H is v(:,1:J)*H(1:J,1:J) | -c | + v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j. | -c %---------------------------------------------% -c - call sgemv ('N', n, j, -one, v, ldv, workd(irj), 1, - & one, resid, 1) - call saxpy (j, one, workd(irj), 1, h(1,j), 1) -c - orth2 = .true. - call arscnd (t2) - if (bmat .eq. 'G') then - nbx = nbx + 1 - call scopy (n, resid, 1, workd(irj), 1) - ipntr(1) = irj - ipntr(2) = ipj - ido = 2 -c -c %-----------------------------------% -c | Exit in order to compute B*r_{j}. | -c | r_{j} is the corrected residual. | -c %-----------------------------------% -c - go to 9000 - else if (bmat .eq. 'I') then - call scopy (n, resid, 1, workd(ipj), 1) - end if - 90 continue -c -c %---------------------------------------------------% -c | Back from reverse communication if ORTH2 = .true. | -c %---------------------------------------------------% -c - if (bmat .eq. 'G') then - call arscnd (t3) - tmvbx = tmvbx + (t3 - t2) - end if -c -c %-----------------------------------------------------% -c | Compute the B-norm of the corrected residual r_{j}. | -c %-----------------------------------------------------% -c - if (bmat .eq. 'G') then - rnorm1 = sdot (n, resid, 1, workd(ipj), 1) - rnorm1 = sqrt(abs(rnorm1)) - else if (bmat .eq. 'I') then - rnorm1 = snrm2(n, resid, 1) - end if -c - if (msglvl .gt. 0 .and. iter .gt. 0) then - call ivout (logfil, 1, j, ndigit, - & '_naitr: Iterative refinement for Arnoldi residual') - if (msglvl .gt. 2) then - xtemp(1) = rnorm - xtemp(2) = rnorm1 - call svout (logfil, 2, xtemp, ndigit, - & '_naitr: iterative refinement ; rnorm and rnorm1 are') - end if - end if -c -c %-----------------------------------------% -c | Determine if we need to perform another | -c | step of re-orthogonalization. | -c %-----------------------------------------% -c - if (rnorm1 .gt. 0.717*rnorm) then -c -c %---------------------------------------% -c | No need for further refinement. | -c | The cosine of the angle between the | -c | corrected residual vector and the old | -c | residual vector is greater than 0.717 | -c | In other words the corrected residual | -c | and the old residual vector share an | -c | angle of less than arcCOS(0.717) | -c %---------------------------------------% -c - rnorm = rnorm1 -c - else -c -c %-------------------------------------------% -c | Another step of iterative refinement step | -c | is required. NITREF is used by stat.h | -c %-------------------------------------------% -c - nitref = nitref + 1 - rnorm = rnorm1 - iter = iter + 1 - if (iter .le. 1) go to 80 -c -c %-------------------------------------------------% -c | Otherwise RESID is numerically in the span of V | -c %-------------------------------------------------% -c - do 95 jj = 1, n - resid(jj) = zero - 95 continue - rnorm = zero - end if -c -c %----------------------------------------------% -c | Branch here directly if iterative refinement | -c | wasn't necessary or after at most NITER_REF | -c | steps of iterative refinement. | -c %----------------------------------------------% -c - 100 continue -c - rstart = .false. - orth2 = .false. -c - call arscnd (t5) - titref = titref + (t5 - t4) -c -c %------------------------------------% -c | STEP 6: Update j = j+1; Continue | -c %------------------------------------% -c - j = j + 1 - if (j .gt. k+np) then - call arscnd (t1) - tnaitr = tnaitr + (t1 - t0) - ido = 99 - do 110 i = max(1,k), k+np-1 -c -c %--------------------------------------------% -c | Check for splitting and deflation. | -c | Use a standard test as in the QR algorithm | -c | REFERENCE: LAPACK subroutine slahqr | -c %--------------------------------------------% -c - tst1 = abs( h( i, i ) ) + abs( h( i+1, i+1 ) ) - if( tst1.eq.zero ) - & tst1 = slanhs( '1', k+np, h, ldh, workd(n+1) ) - if( abs( h( i+1,i ) ).le.max( ulp*tst1, smlnum ) ) - & h(i+1,i) = zero - 110 continue -c - if (msglvl .gt. 2) then - call smout (logfil, k+np, k+np, h, ldh, ndigit, - & '_naitr: Final upper Hessenberg matrix H of order K+NP') - end if -c - go to 9000 - end if -c -c %--------------------------------------------------------% -c | Loop back to extend the factorization by another step. | -c %--------------------------------------------------------% -c - go to 1000 -c -c %---------------------------------------------------------------% -c | | -c | E N D O F M A I N I T E R A T I O N L O O P | -c | | -c %---------------------------------------------------------------% -c - 9000 continue - return -c -c %---------------% -c | End of snaitr | -c %---------------% -c - end
--- a/libcruft/arpack/src/snapps.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,647 +0,0 @@ -c----------------------------------------------------------------------- -c\BeginDoc -c -c\Name: snapps -c -c\Description: -c Given the Arnoldi factorization -c -c A*V_{k} - V_{k}*H_{k} = r_{k+p}*e_{k+p}^T, -c -c apply NP implicit shifts resulting in -c -c A*(V_{k}*Q) - (V_{k}*Q)*(Q^T* H_{k}*Q) = r_{k+p}*e_{k+p}^T * Q -c -c where Q is an orthogonal matrix which is the product of rotations -c and reflections resulting from the NP bulge chage sweeps. -c The updated Arnoldi factorization becomes: -c -c A*VNEW_{k} - VNEW_{k}*HNEW_{k} = rnew_{k}*e_{k}^T. -c -c\Usage: -c call snapps -c ( N, KEV, NP, SHIFTR, SHIFTI, V, LDV, H, LDH, RESID, Q, LDQ, -c WORKL, WORKD ) -c -c\Arguments -c N Integer. (INPUT) -c Problem size, i.e. size of matrix A. -c -c KEV Integer. (INPUT/OUTPUT) -c KEV+NP is the size of the input matrix H. -c KEV is the size of the updated matrix HNEW. KEV is only -c updated on ouput when fewer than NP shifts are applied in -c order to keep the conjugate pair together. -c -c NP Integer. (INPUT) -c Number of implicit shifts to be applied. -c -c SHIFTR, Real array of length NP. (INPUT) -c SHIFTI Real and imaginary part of the shifts to be applied. -c Upon, entry to snapps, the shifts must be sorted so that the -c conjugate pairs are in consecutive locations. -c -c V Real N by (KEV+NP) array. (INPUT/OUTPUT) -c On INPUT, V contains the current KEV+NP Arnoldi vectors. -c On OUTPUT, V contains the updated KEV Arnoldi vectors -c in the first KEV columns of V. -c -c LDV Integer. (INPUT) -c Leading dimension of V exactly as declared in the calling -c program. -c -c H Real (KEV+NP) by (KEV+NP) array. (INPUT/OUTPUT) -c On INPUT, H contains the current KEV+NP by KEV+NP upper -c Hessenber matrix of the Arnoldi factorization. -c On OUTPUT, H contains the updated KEV by KEV upper Hessenberg -c matrix in the KEV leading submatrix. -c -c LDH Integer. (INPUT) -c Leading dimension of H exactly as declared in the calling -c program. -c -c RESID Real array of length N. (INPUT/OUTPUT) -c On INPUT, RESID contains the the residual vector r_{k+p}. -c On OUTPUT, RESID is the update residual vector rnew_{k} -c in the first KEV locations. -c -c Q Real KEV+NP by KEV+NP work array. (WORKSPACE) -c Work array used to accumulate the rotations and reflections -c during the bulge chase sweep. -c -c LDQ Integer. (INPUT) -c Leading dimension of Q exactly as declared in the calling -c program. -c -c WORKL Real work array of length (KEV+NP). (WORKSPACE) -c Private (replicated) array on each PE or array allocated on -c the front end. -c -c WORKD Real work array of length 2*N. (WORKSPACE) -c Distributed array used in the application of the accumulated -c orthogonal matrix Q. -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Local variables: -c xxxxxx real -c -c\References: -c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in -c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), -c pp 357-385. -c -c\Routines called: -c ivout ARPACK utility routine that prints integers. -c arscnd ARPACK utility routine for timing. -c smout ARPACK utility routine that prints matrices. -c svout ARPACK utility routine that prints vectors. -c slabad LAPACK routine that computes machine constants. -c slacpy LAPACK matrix copy routine. -c slamch LAPACK routine that determines machine constants. -c slanhs LAPACK routine that computes various norms of a matrix. -c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. -c slarf LAPACK routine that applies Householder reflection to -c a matrix. -c slarfg LAPACK Householder reflection construction routine. -c slartg LAPACK Givens rotation construction routine. -c slaset LAPACK matrix initialization routine. -c sgemv Level 2 BLAS routine for matrix vector multiplication. -c saxpy Level 1 BLAS that computes a vector triad. -c scopy Level 1 BLAS that copies one vector to another . -c sscal Level 1 BLAS that scales a vector. -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\Revision history: -c xx/xx/92: Version ' 2.4' -c -c\SCCS Information: @(#) -c FILE: napps.F SID: 2.4 DATE OF SID: 3/28/97 RELEASE: 2 -c -c\Remarks -c 1. In this version, each shift is applied to all the sublocks of -c the Hessenberg matrix H and not just to the submatrix that it -c comes from. Deflation as in LAPACK routine slahqr (QR algorithm -c for upper Hessenberg matrices ) is used. -c The subdiagonals of H are enforced to be non-negative. -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine snapps - & ( n, kev, np, shiftr, shifti, v, ldv, h, ldh, resid, q, ldq, - & workl, workd ) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - integer kev, ldh, ldq, ldv, n, np -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - Real - & h(ldh,kev+np), resid(n), shifti(np), shiftr(np), - & v(ldv,kev+np), q(ldq,kev+np), workd(2*n), workl(kev+np) -c -c %------------% -c | Parameters | -c %------------% -c - Real - & one, zero - parameter (one = 1.0E+0, zero = 0.0E+0) -c -c %------------------------% -c | Local Scalars & Arrays | -c %------------------------% -c - integer i, iend, ir, istart, j, jj, kplusp, msglvl, nr - logical cconj, first - Real - & c, f, g, h11, h12, h21, h22, h32, ovfl, r, s, sigmai, - & sigmar, smlnum, ulp, unfl, u(3), t, tau, tst1 - save first, ovfl, smlnum, ulp, unfl -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external saxpy, scopy, sscal, slacpy, slarfg, slarf, - & slaset, slabad, arscnd, slartg -c -c %--------------------% -c | External Functions | -c %--------------------% -c - Real - & slamch, slanhs, slapy2 - external slamch, slanhs, slapy2 -c -c %----------------------% -c | Intrinsics Functions | -c %----------------------% -c - intrinsic abs, max, min -c -c %----------------% -c | Data statments | -c %----------------% -c - data first / .true. / -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c - if (first) then -c -c %-----------------------------------------------% -c | Set machine-dependent constants for the | -c | stopping criterion. If norm(H) <= sqrt(OVFL), | -c | overflow should not occur. | -c | REFERENCE: LAPACK subroutine slahqr | -c %-----------------------------------------------% -c - unfl = slamch( 'safe minimum' ) - ovfl = one / unfl - call slabad( unfl, ovfl ) - ulp = slamch( 'precision' ) - smlnum = unfl*( n / ulp ) - first = .false. - end if -c -c %-------------------------------% -c | Initialize timing statistics | -c | & message level for debugging | -c %-------------------------------% -c - call arscnd (t0) - msglvl = mnapps - kplusp = kev + np -c -c %--------------------------------------------% -c | Initialize Q to the identity to accumulate | -c | the rotations and reflections | -c %--------------------------------------------% -c - call slaset ('All', kplusp, kplusp, zero, one, q, ldq) -c -c %----------------------------------------------% -c | Quick return if there are no shifts to apply | -c %----------------------------------------------% -c - if (np .eq. 0) go to 9000 -c -c %----------------------------------------------% -c | Chase the bulge with the application of each | -c | implicit shift. Each shift is applied to the | -c | whole matrix including each block. | -c %----------------------------------------------% -c - cconj = .false. - do 110 jj = 1, np - sigmar = shiftr(jj) - sigmai = shifti(jj) -c - if (msglvl .gt. 2 ) then - call ivout (logfil, 1, jj, ndigit, - & '_napps: shift number.') - call svout (logfil, 1, sigmar, ndigit, - & '_napps: The real part of the shift ') - call svout (logfil, 1, sigmai, ndigit, - & '_napps: The imaginary part of the shift ') - end if -c -c %-------------------------------------------------% -c | The following set of conditionals is necessary | -c | in order that complex conjugate pairs of shifts | -c | are applied together or not at all. | -c %-------------------------------------------------% -c - if ( cconj ) then -c -c %-----------------------------------------% -c | cconj = .true. means the previous shift | -c | had non-zero imaginary part. | -c %-----------------------------------------% -c - cconj = .false. - go to 110 - else if ( jj .lt. np .and. abs( sigmai ) .gt. zero ) then -c -c %------------------------------------% -c | Start of a complex conjugate pair. | -c %------------------------------------% -c - cconj = .true. - else if ( jj .eq. np .and. abs( sigmai ) .gt. zero ) then -c -c %----------------------------------------------% -c | The last shift has a nonzero imaginary part. | -c | Don't apply it; thus the order of the | -c | compressed H is order KEV+1 since only np-1 | -c | were applied. | -c %----------------------------------------------% -c - kev = kev + 1 - go to 110 - end if - istart = 1 - 20 continue -c -c %--------------------------------------------------% -c | if sigmai = 0 then | -c | Apply the jj-th shift ... | -c | else | -c | Apply the jj-th and (jj+1)-th together ... | -c | (Note that jj < np at this point in the code) | -c | end | -c | to the current block of H. The next do loop | -c | determines the current block ; | -c %--------------------------------------------------% -c - do 30 i = istart, kplusp-1 -c -c %----------------------------------------% -c | Check for splitting and deflation. Use | -c | a standard test as in the QR algorithm | -c | REFERENCE: LAPACK subroutine slahqr | -c %----------------------------------------% -c - tst1 = abs( h( i, i ) ) + abs( h( i+1, i+1 ) ) - if( tst1.eq.zero ) - & tst1 = slanhs( '1', kplusp-jj+1, h, ldh, workl ) - if( abs( h( i+1,i ) ).le.max( ulp*tst1, smlnum ) ) then - if (msglvl .gt. 0) then - call ivout (logfil, 1, i, ndigit, - & '_napps: matrix splitting at row/column no.') - call ivout (logfil, 1, jj, ndigit, - & '_napps: matrix splitting with shift number.') - call svout (logfil, 1, h(i+1,i), ndigit, - & '_napps: off diagonal element.') - end if - iend = i - h(i+1,i) = zero - go to 40 - end if - 30 continue - iend = kplusp - 40 continue -c - if (msglvl .gt. 2) then - call ivout (logfil, 1, istart, ndigit, - & '_napps: Start of current block ') - call ivout (logfil, 1, iend, ndigit, - & '_napps: End of current block ') - end if -c -c %------------------------------------------------% -c | No reason to apply a shift to block of order 1 | -c %------------------------------------------------% -c - if ( istart .eq. iend ) go to 100 -c -c %------------------------------------------------------% -c | If istart + 1 = iend then no reason to apply a | -c | complex conjugate pair of shifts on a 2 by 2 matrix. | -c %------------------------------------------------------% -c - if ( istart + 1 .eq. iend .and. abs( sigmai ) .gt. zero ) - & go to 100 -c - h11 = h(istart,istart) - h21 = h(istart+1,istart) - if ( abs( sigmai ) .le. zero ) then -c -c %---------------------------------------------% -c | Real-valued shift ==> apply single shift QR | -c %---------------------------------------------% -c - f = h11 - sigmar - g = h21 -c - do 80 i = istart, iend-1 -c -c %-----------------------------------------------------% -c | Contruct the plane rotation G to zero out the bulge | -c %-----------------------------------------------------% -c - call slartg (f, g, c, s, r) - if (i .gt. istart) then -c -c %-------------------------------------------% -c | The following ensures that h(1:iend-1,1), | -c | the first iend-2 off diagonal of elements | -c | H, remain non negative. | -c %-------------------------------------------% -c - if (r .lt. zero) then - r = -r - c = -c - s = -s - end if - h(i,i-1) = r - h(i+1,i-1) = zero - end if -c -c %---------------------------------------------% -c | Apply rotation to the left of H; H <- G'*H | -c %---------------------------------------------% -c - do 50 j = i, kplusp - t = c*h(i,j) + s*h(i+1,j) - h(i+1,j) = -s*h(i,j) + c*h(i+1,j) - h(i,j) = t - 50 continue -c -c %---------------------------------------------% -c | Apply rotation to the right of H; H <- H*G | -c %---------------------------------------------% -c - do 60 j = 1, min(i+2,iend) - t = c*h(j,i) + s*h(j,i+1) - h(j,i+1) = -s*h(j,i) + c*h(j,i+1) - h(j,i) = t - 60 continue -c -c %----------------------------------------------------% -c | Accumulate the rotation in the matrix Q; Q <- Q*G | -c %----------------------------------------------------% -c - do 70 j = 1, min( i+jj, kplusp ) - t = c*q(j,i) + s*q(j,i+1) - q(j,i+1) = - s*q(j,i) + c*q(j,i+1) - q(j,i) = t - 70 continue -c -c %---------------------------% -c | Prepare for next rotation | -c %---------------------------% -c - if (i .lt. iend-1) then - f = h(i+1,i) - g = h(i+2,i) - end if - 80 continue -c -c %-----------------------------------% -c | Finished applying the real shift. | -c %-----------------------------------% -c - else -c -c %----------------------------------------------------% -c | Complex conjugate shifts ==> apply double shift QR | -c %----------------------------------------------------% -c - h12 = h(istart,istart+1) - h22 = h(istart+1,istart+1) - h32 = h(istart+2,istart+1) -c -c %---------------------------------------------------------% -c | Compute 1st column of (H - shift*I)*(H - conj(shift)*I) | -c %---------------------------------------------------------% -c - s = 2.0*sigmar - t = slapy2 ( sigmar, sigmai ) - u(1) = ( h11 * (h11 - s) + t * t ) / h21 + h12 - u(2) = h11 + h22 - s - u(3) = h32 -c - do 90 i = istart, iend-1 -c - nr = min ( 3, iend-i+1 ) -c -c %-----------------------------------------------------% -c | Construct Householder reflector G to zero out u(1). | -c | G is of the form I - tau*( 1 u )' * ( 1 u' ). | -c %-----------------------------------------------------% -c - call slarfg ( nr, u(1), u(2), 1, tau ) -c - if (i .gt. istart) then - h(i,i-1) = u(1) - h(i+1,i-1) = zero - if (i .lt. iend-1) h(i+2,i-1) = zero - end if - u(1) = one -c -c %--------------------------------------% -c | Apply the reflector to the left of H | -c %--------------------------------------% -c - call slarf ('Left', nr, kplusp-i+1, u, 1, tau, - & h(i,i), ldh, workl) -c -c %---------------------------------------% -c | Apply the reflector to the right of H | -c %---------------------------------------% -c - ir = min ( i+3, iend ) - call slarf ('Right', ir, nr, u, 1, tau, - & h(1,i), ldh, workl) -c -c %-----------------------------------------------------% -c | Accumulate the reflector in the matrix Q; Q <- Q*G | -c %-----------------------------------------------------% -c - call slarf ('Right', kplusp, nr, u, 1, tau, - & q(1,i), ldq, workl) -c -c %----------------------------% -c | Prepare for next reflector | -c %----------------------------% -c - if (i .lt. iend-1) then - u(1) = h(i+1,i) - u(2) = h(i+2,i) - if (i .lt. iend-2) u(3) = h(i+3,i) - end if -c - 90 continue -c -c %--------------------------------------------% -c | Finished applying a complex pair of shifts | -c | to the current block | -c %--------------------------------------------% -c - end if -c - 100 continue -c -c %---------------------------------------------------------% -c | Apply the same shift to the next block if there is any. | -c %---------------------------------------------------------% -c - istart = iend + 1 - if (iend .lt. kplusp) go to 20 -c -c %---------------------------------------------% -c | Loop back to the top to get the next shift. | -c %---------------------------------------------% -c - 110 continue -c -c %--------------------------------------------------% -c | Perform a similarity transformation that makes | -c | sure that H will have non negative sub diagonals | -c %--------------------------------------------------% -c - do 120 j=1,kev - if ( h(j+1,j) .lt. zero ) then - call sscal( kplusp-j+1, -one, h(j+1,j), ldh ) - call sscal( min(j+2, kplusp), -one, h(1,j+1), 1 ) - call sscal( min(j+np+1,kplusp), -one, q(1,j+1), 1 ) - end if - 120 continue -c - do 130 i = 1, kev -c -c %--------------------------------------------% -c | Final check for splitting and deflation. | -c | Use a standard test as in the QR algorithm | -c | REFERENCE: LAPACK subroutine slahqr | -c %--------------------------------------------% -c - tst1 = abs( h( i, i ) ) + abs( h( i+1, i+1 ) ) - if( tst1.eq.zero ) - & tst1 = slanhs( '1', kev, h, ldh, workl ) - if( h( i+1,i ) .le. max( ulp*tst1, smlnum ) ) - & h(i+1,i) = zero - 130 continue -c -c %-------------------------------------------------% -c | Compute the (kev+1)-st column of (V*Q) and | -c | temporarily store the result in WORKD(N+1:2*N). | -c | This is needed in the residual update since we | -c | cannot GUARANTEE that the corresponding entry | -c | of H would be zero as in exact arithmetic. | -c %-------------------------------------------------% -c - if (h(kev+1,kev) .gt. zero) - & call sgemv ('N', n, kplusp, one, v, ldv, q(1,kev+1), 1, zero, - & workd(n+1), 1) -c -c %----------------------------------------------------------% -c | Compute column 1 to kev of (V*Q) in backward order | -c | taking advantage of the upper Hessenberg structure of Q. | -c %----------------------------------------------------------% -c - do 140 i = 1, kev - call sgemv ('N', n, kplusp-i+1, one, v, ldv, - & q(1,kev-i+1), 1, zero, workd, 1) - call scopy (n, workd, 1, v(1,kplusp-i+1), 1) - 140 continue -c -c %-------------------------------------------------% -c | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). | -c %-------------------------------------------------% -c - call slacpy ('A', n, kev, v(1,kplusp-kev+1), ldv, v, ldv) -c -c %--------------------------------------------------------------% -c | Copy the (kev+1)-st column of (V*Q) in the appropriate place | -c %--------------------------------------------------------------% -c - if (h(kev+1,kev) .gt. zero) - & call scopy (n, workd(n+1), 1, v(1,kev+1), 1) -c -c %-------------------------------------% -c | Update the residual vector: | -c | r <- sigmak*r + betak*v(:,kev+1) | -c | where | -c | sigmak = (e_{kplusp}'*Q)*e_{kev} | -c | betak = e_{kev+1}'*H*e_{kev} | -c %-------------------------------------% -c - call sscal (n, q(kplusp,kev), resid, 1) - if (h(kev+1,kev) .gt. zero) - & call saxpy (n, h(kev+1,kev), v(1,kev+1), 1, resid, 1) -c - if (msglvl .gt. 1) then - call svout (logfil, 1, q(kplusp,kev), ndigit, - & '_napps: sigmak = (e_{kev+p}^T*Q)*e_{kev}') - call svout (logfil, 1, h(kev+1,kev), ndigit, - & '_napps: betak = e_{kev+1}^T*H*e_{kev}') - call ivout (logfil, 1, kev, ndigit, - & '_napps: Order of the final Hessenberg matrix ') - if (msglvl .gt. 2) then - call smout (logfil, kev, kev, h, ldh, ndigit, - & '_napps: updated Hessenberg matrix H for next iteration') - end if -c - end if -c - 9000 continue - call arscnd (t1) - tnapps = tnapps + (t1 - t0) -c - return -c -c %---------------% -c | End of snapps | -c %---------------% -c - end
--- a/libcruft/arpack/src/snaup2.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,835 +0,0 @@ -c\BeginDoc -c -c\Name: snaup2 -c -c\Description: -c Intermediate level interface called by snaupd. -c -c\Usage: -c call snaup2 -c ( IDO, BMAT, N, WHICH, NEV, NP, TOL, RESID, MODE, IUPD, -c ISHIFT, MXITER, V, LDV, H, LDH, RITZR, RITZI, BOUNDS, -c Q, LDQ, WORKL, IPNTR, WORKD, INFO ) -c -c\Arguments -c -c IDO, BMAT, N, WHICH, NEV, TOL, RESID: same as defined in snaupd. -c MODE, ISHIFT, MXITER: see the definition of IPARAM in snaupd. -c -c NP Integer. (INPUT/OUTPUT) -c Contains the number of implicit shifts to apply during -c each Arnoldi iteration. -c If ISHIFT=1, NP is adjusted dynamically at each iteration -c to accelerate convergence and prevent stagnation. -c This is also roughly equal to the number of matrix-vector -c products (involving the operator OP) per Arnoldi iteration. -c The logic for adjusting is contained within the current -c subroutine. -c If ISHIFT=0, NP is the number of shifts the user needs -c to provide via reverse comunication. 0 < NP < NCV-NEV. -c NP may be less than NCV-NEV for two reasons. The first, is -c to keep complex conjugate pairs of "wanted" Ritz values -c together. The second, is that a leading block of the current -c upper Hessenberg matrix has split off and contains "unwanted" -c Ritz values. -c Upon termination of the IRA iteration, NP contains the number -c of "converged" wanted Ritz values. -c -c IUPD Integer. (INPUT) -c IUPD .EQ. 0: use explicit restart instead implicit update. -c IUPD .NE. 0: use implicit update. -c -c V Real N by (NEV+NP) array. (INPUT/OUTPUT) -c The Arnoldi basis vectors are returned in the first NEV -c columns of V. -c -c LDV Integer. (INPUT) -c Leading dimension of V exactly as declared in the calling -c program. -c -c H Real (NEV+NP) by (NEV+NP) array. (OUTPUT) -c H is used to store the generated upper Hessenberg matrix -c -c LDH Integer. (INPUT) -c Leading dimension of H exactly as declared in the calling -c program. -c -c RITZR, Real arrays of length NEV+NP. (OUTPUT) -c RITZI RITZR(1:NEV) (resp. RITZI(1:NEV)) contains the real (resp. -c imaginary) part of the computed Ritz values of OP. -c -c BOUNDS Real array of length NEV+NP. (OUTPUT) -c BOUNDS(1:NEV) contain the error bounds corresponding to -c the computed Ritz values. -c -c Q Real (NEV+NP) by (NEV+NP) array. (WORKSPACE) -c Private (replicated) work array used to accumulate the -c rotation in the shift application step. -c -c LDQ Integer. (INPUT) -c Leading dimension of Q exactly as declared in the calling -c program. -c -c WORKL Real work array of length at least -c (NEV+NP)**2 + 3*(NEV+NP). (INPUT/WORKSPACE) -c Private (replicated) array on each PE or array allocated on -c the front end. It is used in shifts calculation, shifts -c application and convergence checking. -c -c On exit, the last 3*(NEV+NP) locations of WORKL contain -c the Ritz values (real,imaginary) and associated Ritz -c estimates of the current Hessenberg matrix. They are -c listed in the same order as returned from sneigh. -c -c If ISHIFT .EQ. O and IDO .EQ. 3, the first 2*NP locations -c of WORKL are used in reverse communication to hold the user -c supplied shifts. -c -c IPNTR Integer array of length 3. (OUTPUT) -c Pointer to mark the starting locations in the WORKD for -c vectors used by the Arnoldi iteration. -c ------------------------------------------------------------- -c IPNTR(1): pointer to the current operand vector X. -c IPNTR(2): pointer to the current result vector Y. -c IPNTR(3): pointer to the vector B * X when used in the -c shift-and-invert mode. X is the current operand. -c ------------------------------------------------------------- -c -c WORKD Real work array of length 3*N. (WORKSPACE) -c Distributed array to be used in the basic Arnoldi iteration -c for reverse communication. The user should not use WORKD -c as temporary workspace during the iteration !!!!!!!!!! -c See Data Distribution Note in DNAUPD. -c -c INFO Integer. (INPUT/OUTPUT) -c If INFO .EQ. 0, a randomly initial residual vector is used. -c If INFO .NE. 0, RESID contains the initial residual vector, -c possibly from a previous run. -c Error flag on output. -c = 0: Normal return. -c = 1: Maximum number of iterations taken. -c All possible eigenvalues of OP has been found. -c NP returns the number of converged Ritz values. -c = 2: No shifts could be applied. -c = -8: Error return from LAPACK eigenvalue calculation; -c This should never happen. -c = -9: Starting vector is zero. -c = -9999: Could not build an Arnoldi factorization. -c Size that was built in returned in NP. -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Local variables: -c xxxxxx real -c -c\References: -c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in -c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), -c pp 357-385. -c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly -c Restarted Arnoldi Iteration", Rice University Technical Report -c TR95-13, Department of Computational and Applied Mathematics. -c -c\Routines called: -c sgetv0 ARPACK initial vector generation routine. -c snaitr ARPACK Arnoldi factorization routine. -c snapps ARPACK application of implicit shifts routine. -c snconv ARPACK convergence of Ritz values routine. -c sneigh ARPACK compute Ritz values and error bounds routine. -c sngets ARPACK reorder Ritz values and error bounds routine. -c ssortc ARPACK sorting routine. -c ivout ARPACK utility routine that prints integers. -c arscnd ARPACK utility routine for timing. -c smout ARPACK utility routine that prints matrices -c svout ARPACK utility routine that prints vectors. -c slamch LAPACK routine that determines machine constants. -c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. -c scopy Level 1 BLAS that copies one vector to another . -c sdot Level 1 BLAS that computes the scalar product of two vectors. -c snrm2 Level 1 BLAS that computes the norm of a vector. -c sswap Level 1 BLAS that swaps two vectors. -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\SCCS Information: @(#) -c FILE: naup2.F SID: 2.8 DATE OF SID: 10/17/00 RELEASE: 2 -c -c\Remarks -c 1. None -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine snaup2 - & ( ido, bmat, n, which, nev, np, tol, resid, mode, iupd, - & ishift, mxiter, v, ldv, h, ldh, ritzr, ritzi, bounds, - & q, ldq, workl, ipntr, workd, info ) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - character bmat*1, which*2 - integer ido, info, ishift, iupd, mode, ldh, ldq, ldv, mxiter, - & n, nev, np - Real - & tol -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - integer ipntr(13) - Real - & bounds(nev+np), h(ldh,nev+np), q(ldq,nev+np), resid(n), - & ritzi(nev+np), ritzr(nev+np), v(ldv,nev+np), - & workd(3*n), workl( (nev+np)*(nev+np+3) ) -c -c %------------% -c | Parameters | -c %------------% -c - Real - & one, zero - parameter (one = 1.0E+0 , zero = 0.0E+0 ) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - character wprime*2 - logical cnorm , getv0, initv, update, ushift - integer ierr , iter , j , kplusp, msglvl, nconv, - & nevbef, nev0 , np0 , nptemp, numcnv - Real - & rnorm , temp , eps23 - save cnorm , getv0, initv, update, ushift, - & rnorm , iter , eps23, kplusp, msglvl, nconv , - & nevbef, nev0 , np0 , numcnv -c -c %-----------------------% -c | Local array arguments | -c %-----------------------% -c - integer kp(4) -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external scopy , sgetv0, snaitr, snconv, sneigh, - & sngets, snapps, svout , ivout , arscnd -c -c %--------------------% -c | External Functions | -c %--------------------% -c - Real - & sdot, snrm2, slapy2, slamch - external sdot, snrm2, slapy2, slamch -c -c %---------------------% -c | Intrinsic Functions | -c %---------------------% -c - intrinsic min, max, abs, sqrt -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c - if (ido .eq. 0) then -c - call arscnd (t0) -c - msglvl = mnaup2 -c -c %-------------------------------------% -c | Get the machine dependent constant. | -c %-------------------------------------% -c - eps23 = slamch('Epsilon-Machine') - eps23 = eps23**(2.0E+0 / 3.0E+0 ) -c - nev0 = nev - np0 = np -c -c %-------------------------------------% -c | kplusp is the bound on the largest | -c | Lanczos factorization built. | -c | nconv is the current number of | -c | "converged" eigenvlues. | -c | iter is the counter on the current | -c | iteration step. | -c %-------------------------------------% -c - kplusp = nev + np - nconv = 0 - iter = 0 -c -c %---------------------------------------% -c | Set flags for computing the first NEV | -c | steps of the Arnoldi factorization. | -c %---------------------------------------% -c - getv0 = .true. - update = .false. - ushift = .false. - cnorm = .false. -c - if (info .ne. 0) then -c -c %--------------------------------------------% -c | User provides the initial residual vector. | -c %--------------------------------------------% -c - initv = .true. - info = 0 - else - initv = .false. - end if - end if -c -c %---------------------------------------------% -c | Get a possibly random starting vector and | -c | force it into the range of the operator OP. | -c %---------------------------------------------% -c - 10 continue -c - if (getv0) then - call sgetv0 (ido, bmat, 1, initv, n, 1, v, ldv, resid, rnorm, - & ipntr, workd, info) -c - if (ido .ne. 99) go to 9000 -c - if (rnorm .eq. zero) then -c -c %-----------------------------------------% -c | The initial vector is zero. Error exit. | -c %-----------------------------------------% -c - info = -9 - go to 1100 - end if - getv0 = .false. - ido = 0 - end if -c -c %-----------------------------------% -c | Back from reverse communication : | -c | continue with update step | -c %-----------------------------------% -c - if (update) go to 20 -c -c %-------------------------------------------% -c | Back from computing user specified shifts | -c %-------------------------------------------% -c - if (ushift) go to 50 -c -c %-------------------------------------% -c | Back from computing residual norm | -c | at the end of the current iteration | -c %-------------------------------------% -c - if (cnorm) go to 100 -c -c %----------------------------------------------------------% -c | Compute the first NEV steps of the Arnoldi factorization | -c %----------------------------------------------------------% -c - call snaitr (ido, bmat, n, 0, nev, mode, resid, rnorm, v, ldv, - & h, ldh, ipntr, workd, info) -c -c %---------------------------------------------------% -c | ido .ne. 99 implies use of reverse communication | -c | to compute operations involving OP and possibly B | -c %---------------------------------------------------% -c - if (ido .ne. 99) go to 9000 -c - if (info .gt. 0) then - np = info - mxiter = iter - info = -9999 - go to 1200 - end if -c -c %--------------------------------------------------------------% -c | | -c | M A I N ARNOLDI I T E R A T I O N L O O P | -c | Each iteration implicitly restarts the Arnoldi | -c | factorization in place. | -c | | -c %--------------------------------------------------------------% -c - 1000 continue -c - iter = iter + 1 -c - if (msglvl .gt. 0) then - call ivout (logfil, 1, iter, ndigit, - & '_naup2: **** Start of major iteration number ****') - end if -c -c %-----------------------------------------------------------% -c | Compute NP additional steps of the Arnoldi factorization. | -c | Adjust NP since NEV might have been updated by last call | -c | to the shift application routine snapps. | -c %-----------------------------------------------------------% -c - np = kplusp - nev -c - if (msglvl .gt. 1) then - call ivout (logfil, 1, nev, ndigit, - & '_naup2: The length of the current Arnoldi factorization') - call ivout (logfil, 1, np, ndigit, - & '_naup2: Extend the Arnoldi factorization by') - end if -c -c %-----------------------------------------------------------% -c | Compute NP additional steps of the Arnoldi factorization. | -c %-----------------------------------------------------------% -c - ido = 0 - 20 continue - update = .true. -c - call snaitr (ido , bmat, n , nev, np , mode , resid, - & rnorm, v , ldv, h , ldh, ipntr, workd, - & info) -c -c %---------------------------------------------------% -c | ido .ne. 99 implies use of reverse communication | -c | to compute operations involving OP and possibly B | -c %---------------------------------------------------% -c - if (ido .ne. 99) go to 9000 -c - if (info .gt. 0) then - np = info - mxiter = iter - info = -9999 - go to 1200 - end if - update = .false. -c - if (msglvl .gt. 1) then - call svout (logfil, 1, rnorm, ndigit, - & '_naup2: Corresponding B-norm of the residual') - end if -c -c %--------------------------------------------------------% -c | Compute the eigenvalues and corresponding error bounds | -c | of the current upper Hessenberg matrix. | -c %--------------------------------------------------------% -c - call sneigh (rnorm, kplusp, h, ldh, ritzr, ritzi, bounds, - & q, ldq, workl, ierr) -c - if (ierr .ne. 0) then - info = -8 - go to 1200 - end if -c -c %----------------------------------------------------% -c | Make a copy of eigenvalues and corresponding error | -c | bounds obtained from sneigh. | -c %----------------------------------------------------% -c - call scopy(kplusp, ritzr, 1, workl(kplusp**2+1), 1) - call scopy(kplusp, ritzi, 1, workl(kplusp**2+kplusp+1), 1) - call scopy(kplusp, bounds, 1, workl(kplusp**2+2*kplusp+1), 1) -c -c %---------------------------------------------------% -c | Select the wanted Ritz values and their bounds | -c | to be used in the convergence test. | -c | The wanted part of the spectrum and corresponding | -c | error bounds are in the last NEV loc. of RITZR, | -c | RITZI and BOUNDS respectively. The variables NEV | -c | and NP may be updated if the NEV-th wanted Ritz | -c | value has a non zero imaginary part. In this case | -c | NEV is increased by one and NP decreased by one. | -c | NOTE: The last two arguments of sngets are no | -c | longer used as of version 2.1. | -c %---------------------------------------------------% -c - nev = nev0 - np = np0 - numcnv = nev - call sngets (ishift, which, nev, np, ritzr, ritzi, - & bounds, workl, workl(np+1)) - if (nev .eq. nev0+1) numcnv = nev0+1 -c -c %-------------------% -c | Convergence test. | -c %-------------------% -c - call scopy (nev, bounds(np+1), 1, workl(2*np+1), 1) - call snconv (nev, ritzr(np+1), ritzi(np+1), workl(2*np+1), - & tol, nconv) -c - if (msglvl .gt. 2) then - kp(1) = nev - kp(2) = np - kp(3) = numcnv - kp(4) = nconv - call ivout (logfil, 4, kp, ndigit, - & '_naup2: NEV, NP, NUMCNV, NCONV are') - call svout (logfil, kplusp, ritzr, ndigit, - & '_naup2: Real part of the eigenvalues of H') - call svout (logfil, kplusp, ritzi, ndigit, - & '_naup2: Imaginary part of the eigenvalues of H') - call svout (logfil, kplusp, bounds, ndigit, - & '_naup2: Ritz estimates of the current NCV Ritz values') - end if -c -c %---------------------------------------------------------% -c | Count the number of unwanted Ritz values that have zero | -c | Ritz estimates. If any Ritz estimates are equal to zero | -c | then a leading block of H of order equal to at least | -c | the number of Ritz values with zero Ritz estimates has | -c | split off. None of these Ritz values may be removed by | -c | shifting. Decrease NP the number of shifts to apply. If | -c | no shifts may be applied, then prepare to exit | -c %---------------------------------------------------------% -c - nptemp = np - do 30 j=1, nptemp - if (bounds(j) .eq. zero) then - np = np - 1 - nev = nev + 1 - end if - 30 continue -c - if ( (nconv .ge. numcnv) .or. - & (iter .gt. mxiter) .or. - & (np .eq. 0) ) then -c - if (msglvl .gt. 4) then - call svout(logfil, kplusp, workl(kplusp**2+1), ndigit, - & '_naup2: Real part of the eig computed by _neigh:') - call svout(logfil, kplusp, workl(kplusp**2+kplusp+1), - & ndigit, - & '_naup2: Imag part of the eig computed by _neigh:') - call svout(logfil, kplusp, workl(kplusp**2+kplusp*2+1), - & ndigit, - & '_naup2: Ritz eistmates computed by _neigh:') - end if -c -c %------------------------------------------------% -c | Prepare to exit. Put the converged Ritz values | -c | and corresponding bounds in RITZ(1:NCONV) and | -c | BOUNDS(1:NCONV) respectively. Then sort. Be | -c | careful when NCONV > NP | -c %------------------------------------------------% -c -c %------------------------------------------% -c | Use h( 3,1 ) as storage to communicate | -c | rnorm to _neupd if needed | -c %------------------------------------------% - - h(3,1) = rnorm -c -c %----------------------------------------------% -c | To be consistent with sngets, we first do a | -c | pre-processing sort in order to keep complex | -c | conjugate pairs together. This is similar | -c | to the pre-processing sort used in sngets | -c | except that the sort is done in the opposite | -c | order. | -c %----------------------------------------------% -c - if (which .eq. 'LM') wprime = 'SR' - if (which .eq. 'SM') wprime = 'LR' - if (which .eq. 'LR') wprime = 'SM' - if (which .eq. 'SR') wprime = 'LM' - if (which .eq. 'LI') wprime = 'SM' - if (which .eq. 'SI') wprime = 'LM' -c - call ssortc (wprime, .true., kplusp, ritzr, ritzi, bounds) -c -c %----------------------------------------------% -c | Now sort Ritz values so that converged Ritz | -c | values appear within the first NEV locations | -c | of ritzr, ritzi and bounds, and the most | -c | desired one appears at the front. | -c %----------------------------------------------% -c - if (which .eq. 'LM') wprime = 'SM' - if (which .eq. 'SM') wprime = 'LM' - if (which .eq. 'LR') wprime = 'SR' - if (which .eq. 'SR') wprime = 'LR' - if (which .eq. 'LI') wprime = 'SI' - if (which .eq. 'SI') wprime = 'LI' -c - call ssortc(wprime, .true., kplusp, ritzr, ritzi, bounds) -c -c %--------------------------------------------------% -c | Scale the Ritz estimate of each Ritz value | -c | by 1 / max(eps23,magnitude of the Ritz value). | -c %--------------------------------------------------% -c - do 35 j = 1, numcnv - temp = max(eps23,slapy2(ritzr(j), - & ritzi(j))) - bounds(j) = bounds(j)/temp - 35 continue -c -c %----------------------------------------------------% -c | Sort the Ritz values according to the scaled Ritz | -c | esitmates. This will push all the converged ones | -c | towards the front of ritzr, ritzi, bounds | -c | (in the case when NCONV < NEV.) | -c %----------------------------------------------------% -c - wprime = 'LR' - call ssortc(wprime, .true., numcnv, bounds, ritzr, ritzi) -c -c %----------------------------------------------% -c | Scale the Ritz estimate back to its original | -c | value. | -c %----------------------------------------------% -c - do 40 j = 1, numcnv - temp = max(eps23, slapy2(ritzr(j), - & ritzi(j))) - bounds(j) = bounds(j)*temp - 40 continue -c -c %------------------------------------------------% -c | Sort the converged Ritz values again so that | -c | the "threshold" value appears at the front of | -c | ritzr, ritzi and bound. | -c %------------------------------------------------% -c - call ssortc(which, .true., nconv, ritzr, ritzi, bounds) -c - if (msglvl .gt. 1) then - call svout (logfil, kplusp, ritzr, ndigit, - & '_naup2: Sorted real part of the eigenvalues') - call svout (logfil, kplusp, ritzi, ndigit, - & '_naup2: Sorted imaginary part of the eigenvalues') - call svout (logfil, kplusp, bounds, ndigit, - & '_naup2: Sorted ritz estimates.') - end if -c -c %------------------------------------% -c | Max iterations have been exceeded. | -c %------------------------------------% -c - if (iter .gt. mxiter .and. nconv .lt. numcnv) info = 1 -c -c %---------------------% -c | No shifts to apply. | -c %---------------------% -c - if (np .eq. 0 .and. nconv .lt. numcnv) info = 2 -c - np = nconv - go to 1100 -c - else if ( (nconv .lt. numcnv) .and. (ishift .eq. 1) ) then -c -c %-------------------------------------------------% -c | Do not have all the requested eigenvalues yet. | -c | To prevent possible stagnation, adjust the size | -c | of NEV. | -c %-------------------------------------------------% -c - nevbef = nev - nev = nev + min(nconv, np/2) - if (nev .eq. 1 .and. kplusp .ge. 6) then - nev = kplusp / 2 - else if (nev .eq. 1 .and. kplusp .gt. 3) then - nev = 2 - end if - np = kplusp - nev -c -c %---------------------------------------% -c | If the size of NEV was just increased | -c | resort the eigenvalues. | -c %---------------------------------------% -c - if (nevbef .lt. nev) - & call sngets (ishift, which, nev, np, ritzr, ritzi, - & bounds, workl, workl(np+1)) -c - end if -c - if (msglvl .gt. 0) then - call ivout (logfil, 1, nconv, ndigit, - & '_naup2: no. of "converged" Ritz values at this iter.') - if (msglvl .gt. 1) then - kp(1) = nev - kp(2) = np - call ivout (logfil, 2, kp, ndigit, - & '_naup2: NEV and NP are') - call svout (logfil, nev, ritzr(np+1), ndigit, - & '_naup2: "wanted" Ritz values -- real part') - call svout (logfil, nev, ritzi(np+1), ndigit, - & '_naup2: "wanted" Ritz values -- imag part') - call svout (logfil, nev, bounds(np+1), ndigit, - & '_naup2: Ritz estimates of the "wanted" values ') - end if - end if -c - if (ishift .eq. 0) then -c -c %-------------------------------------------------------% -c | User specified shifts: reverse comminucation to | -c | compute the shifts. They are returned in the first | -c | 2*NP locations of WORKL. | -c %-------------------------------------------------------% -c - ushift = .true. - ido = 3 - go to 9000 - end if -c - 50 continue -c -c %------------------------------------% -c | Back from reverse communication; | -c | User specified shifts are returned | -c | in WORKL(1:2*NP) | -c %------------------------------------% -c - ushift = .false. -c - if ( ishift .eq. 0 ) then -c -c %----------------------------------% -c | Move the NP shifts from WORKL to | -c | RITZR, RITZI to free up WORKL | -c | for non-exact shift case. | -c %----------------------------------% -c - call scopy (np, workl, 1, ritzr, 1) - call scopy (np, workl(np+1), 1, ritzi, 1) - end if -c - if (msglvl .gt. 2) then - call ivout (logfil, 1, np, ndigit, - & '_naup2: The number of shifts to apply ') - call svout (logfil, np, ritzr, ndigit, - & '_naup2: Real part of the shifts') - call svout (logfil, np, ritzi, ndigit, - & '_naup2: Imaginary part of the shifts') - if ( ishift .eq. 1 ) - & call svout (logfil, np, bounds, ndigit, - & '_naup2: Ritz estimates of the shifts') - end if -c -c %---------------------------------------------------------% -c | Apply the NP implicit shifts by QR bulge chasing. | -c | Each shift is applied to the whole upper Hessenberg | -c | matrix H. | -c | The first 2*N locations of WORKD are used as workspace. | -c %---------------------------------------------------------% -c - call snapps (n, nev, np, ritzr, ritzi, v, ldv, - & h, ldh, resid, q, ldq, workl, workd) -c -c %---------------------------------------------% -c | Compute the B-norm of the updated residual. | -c | Keep B*RESID in WORKD(1:N) to be used in | -c | the first step of the next call to snaitr. | -c %---------------------------------------------% -c - cnorm = .true. - call arscnd (t2) - if (bmat .eq. 'G') then - nbx = nbx + 1 - call scopy (n, resid, 1, workd(n+1), 1) - ipntr(1) = n + 1 - ipntr(2) = 1 - ido = 2 -c -c %----------------------------------% -c | Exit in order to compute B*RESID | -c %----------------------------------% -c - go to 9000 - else if (bmat .eq. 'I') then - call scopy (n, resid, 1, workd, 1) - end if -c - 100 continue -c -c %----------------------------------% -c | Back from reverse communication; | -c | WORKD(1:N) := B*RESID | -c %----------------------------------% -c - if (bmat .eq. 'G') then - call arscnd (t3) - tmvbx = tmvbx + (t3 - t2) - end if -c - if (bmat .eq. 'G') then - rnorm = sdot (n, resid, 1, workd, 1) - rnorm = sqrt(abs(rnorm)) - else if (bmat .eq. 'I') then - rnorm = snrm2(n, resid, 1) - end if - cnorm = .false. -c - if (msglvl .gt. 2) then - call svout (logfil, 1, rnorm, ndigit, - & '_naup2: B-norm of residual for compressed factorization') - call smout (logfil, nev, nev, h, ldh, ndigit, - & '_naup2: Compressed upper Hessenberg matrix H') - end if -c - go to 1000 -c -c %---------------------------------------------------------------% -c | | -c | E N D O F M A I N I T E R A T I O N L O O P | -c | | -c %---------------------------------------------------------------% -c - 1100 continue -c - mxiter = iter - nev = numcnv -c - 1200 continue - ido = 99 -c -c %------------% -c | Error Exit | -c %------------% -c - call arscnd (t1) - tnaup2 = t1 - t0 -c - 9000 continue -c -c %---------------% -c | End of snaup2 | -c %---------------% -c - return - end
--- a/libcruft/arpack/src/snaupd.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,693 +0,0 @@ -c\BeginDoc -c -c\Name: snaupd -c -c\Description: -c Reverse communication interface for the Implicitly Restarted Arnoldi -c iteration. This subroutine computes approximations to a few eigenpairs -c of a linear operator "OP" with respect to a semi-inner product defined by -c a symmetric positive semi-definite real matrix B. B may be the identity -c matrix. NOTE: If the linear operator "OP" is real and symmetric -c with respect to the real positive semi-definite symmetric matrix B, -c i.e. B*OP = (OP`)*B, then subroutine ssaupd should be used instead. -c -c The computed approximate eigenvalues are called Ritz values and -c the corresponding approximate eigenvectors are called Ritz vectors. -c -c snaupd is usually called iteratively to solve one of the -c following problems: -c -c Mode 1: A*x = lambda*x. -c ===> OP = A and B = I. -c -c Mode 2: A*x = lambda*M*x, M symmetric positive definite -c ===> OP = inv[M]*A and B = M. -c ===> (If M can be factored see remark 3 below) -c -c Mode 3: A*x = lambda*M*x, M symmetric semi-definite -c ===> OP = Real_Part{ inv[A - sigma*M]*M } and B = M. -c ===> shift-and-invert mode (in real arithmetic) -c If OP*x = amu*x, then -c amu = 1/2 * [ 1/(lambda-sigma) + 1/(lambda-conjg(sigma)) ]. -c Note: If sigma is real, i.e. imaginary part of sigma is zero; -c Real_Part{ inv[A - sigma*M]*M } == inv[A - sigma*M]*M -c amu == 1/(lambda-sigma). -c -c Mode 4: A*x = lambda*M*x, M symmetric semi-definite -c ===> OP = Imaginary_Part{ inv[A - sigma*M]*M } and B = M. -c ===> shift-and-invert mode (in real arithmetic) -c If OP*x = amu*x, then -c amu = 1/2i * [ 1/(lambda-sigma) - 1/(lambda-conjg(sigma)) ]. -c -c Both mode 3 and 4 give the same enhancement to eigenvalues close to -c the (complex) shift sigma. However, as lambda goes to infinity, -c the operator OP in mode 4 dampens the eigenvalues more strongly than -c does OP defined in mode 3. -c -c NOTE: The action of w <- inv[A - sigma*M]*v or w <- inv[M]*v -c should be accomplished either by a direct method -c using a sparse matrix factorization and solving -c -c [A - sigma*M]*w = v or M*w = v, -c -c or through an iterative method for solving these -c systems. If an iterative method is used, the -c convergence test must be more stringent than -c the accuracy requirements for the eigenvalue -c approximations. -c -c\Usage: -c call snaupd -c ( IDO, BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, -c IPNTR, WORKD, WORKL, LWORKL, INFO ) -c -c\Arguments -c IDO Integer. (INPUT/OUTPUT) -c Reverse communication flag. IDO must be zero on the first -c call to snaupd. IDO will be set internally to -c indicate the type of operation to be performed. Control is -c then given back to the calling routine which has the -c responsibility to carry out the requested operation and call -c snaupd with the result. The operand is given in -c WORKD(IPNTR(1)), the result must be put in WORKD(IPNTR(2)). -c ------------------------------------------------------------- -c IDO = 0: first call to the reverse communication interface -c IDO = -1: compute Y = OP * X where -c IPNTR(1) is the pointer into WORKD for X, -c IPNTR(2) is the pointer into WORKD for Y. -c This is for the initialization phase to force the -c starting vector into the range of OP. -c IDO = 1: compute Y = OP * X where -c IPNTR(1) is the pointer into WORKD for X, -c IPNTR(2) is the pointer into WORKD for Y. -c In mode 3 and 4, the vector B * X is already -c available in WORKD(ipntr(3)). It does not -c need to be recomputed in forming OP * X. -c IDO = 2: compute Y = B * X where -c IPNTR(1) is the pointer into WORKD for X, -c IPNTR(2) is the pointer into WORKD for Y. -c IDO = 3: compute the IPARAM(8) real and imaginary parts -c of the shifts where INPTR(14) is the pointer -c into WORKL for placing the shifts. See Remark -c 5 below. -c IDO = 99: done -c ------------------------------------------------------------- -c -c BMAT Character*1. (INPUT) -c BMAT specifies the type of the matrix B that defines the -c semi-inner product for the operator OP. -c BMAT = 'I' -> standard eigenvalue problem A*x = lambda*x -c BMAT = 'G' -> generalized eigenvalue problem A*x = lambda*B*x -c -c N Integer. (INPUT) -c Dimension of the eigenproblem. -c -c WHICH Character*2. (INPUT) -c 'LM' -> want the NEV eigenvalues of largest magnitude. -c 'SM' -> want the NEV eigenvalues of smallest magnitude. -c 'LR' -> want the NEV eigenvalues of largest real part. -c 'SR' -> want the NEV eigenvalues of smallest real part. -c 'LI' -> want the NEV eigenvalues of largest imaginary part. -c 'SI' -> want the NEV eigenvalues of smallest imaginary part. -c -c NEV Integer. (INPUT) -c Number of eigenvalues of OP to be computed. 0 < NEV < N-1. -c -c TOL Real scalar. (INPUT) -c Stopping criterion: the relative accuracy of the Ritz value -c is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I)) -c where ABS(RITZ(I)) is the magnitude when RITZ(I) is complex. -c DEFAULT = SLAMCH('EPS') (machine precision as computed -c by the LAPACK auxiliary subroutine SLAMCH). -c -c RESID Real array of length N. (INPUT/OUTPUT) -c On INPUT: -c If INFO .EQ. 0, a random initial residual vector is used. -c If INFO .NE. 0, RESID contains the initial residual vector, -c possibly from a previous run. -c On OUTPUT: -c RESID contains the final residual vector. -c -c NCV Integer. (INPUT) -c Number of columns of the matrix V. NCV must satisfy the two -c inequalities 2 <= NCV-NEV and NCV <= N. -c This will indicate how many Arnoldi vectors are generated -c at each iteration. After the startup phase in which NEV -c Arnoldi vectors are generated, the algorithm generates -c approximately NCV-NEV Arnoldi vectors at each subsequent update -c iteration. Most of the cost in generating each Arnoldi vector is -c in the matrix-vector operation OP*x. -c NOTE: 2 <= NCV-NEV in order that complex conjugate pairs of Ritz -c values are kept together. (See remark 4 below) -c -c V Real array N by NCV. (OUTPUT) -c Contains the final set of Arnoldi basis vectors. -c -c LDV Integer. (INPUT) -c Leading dimension of V exactly as declared in the calling program. -c -c IPARAM Integer array of length 11. (INPUT/OUTPUT) -c IPARAM(1) = ISHIFT: method for selecting the implicit shifts. -c The shifts selected at each iteration are used to restart -c the Arnoldi iteration in an implicit fashion. -c ------------------------------------------------------------- -c ISHIFT = 0: the shifts are provided by the user via -c reverse communication. The real and imaginary -c parts of the NCV eigenvalues of the Hessenberg -c matrix H are returned in the part of the WORKL -c array corresponding to RITZR and RITZI. See remark -c 5 below. -c ISHIFT = 1: exact shifts with respect to the current -c Hessenberg matrix H. This is equivalent to -c restarting the iteration with a starting vector -c that is a linear combination of approximate Schur -c vectors associated with the "wanted" Ritz values. -c ------------------------------------------------------------- -c -c IPARAM(2) = No longer referenced. -c -c IPARAM(3) = MXITER -c On INPUT: maximum number of Arnoldi update iterations allowed. -c On OUTPUT: actual number of Arnoldi update iterations taken. -c -c IPARAM(4) = NB: blocksize to be used in the recurrence. -c The code currently works only for NB = 1. -c -c IPARAM(5) = NCONV: number of "converged" Ritz values. -c This represents the number of Ritz values that satisfy -c the convergence criterion. -c -c IPARAM(6) = IUPD -c No longer referenced. Implicit restarting is ALWAYS used. -c -c IPARAM(7) = MODE -c On INPUT determines what type of eigenproblem is being solved. -c Must be 1,2,3,4; See under \Description of snaupd for the -c four modes available. -c -c IPARAM(8) = NP -c When ido = 3 and the user provides shifts through reverse -c communication (IPARAM(1)=0), snaupd returns NP, the number -c of shifts the user is to provide. 0 < NP <=NCV-NEV. See Remark -c 5 below. -c -c IPARAM(9) = NUMOP, IPARAM(10) = NUMOPB, IPARAM(11) = NUMREO, -c OUTPUT: NUMOP = total number of OP*x operations, -c NUMOPB = total number of B*x operations if BMAT='G', -c NUMREO = total number of steps of re-orthogonalization. -c -c IPNTR Integer array of length 14. (OUTPUT) -c Pointer to mark the starting locations in the WORKD and WORKL -c arrays for matrices/vectors used by the Arnoldi iteration. -c ------------------------------------------------------------- -c IPNTR(1): pointer to the current operand vector X in WORKD. -c IPNTR(2): pointer to the current result vector Y in WORKD. -c IPNTR(3): pointer to the vector B * X in WORKD when used in -c the shift-and-invert mode. -c IPNTR(4): pointer to the next available location in WORKL -c that is untouched by the program. -c IPNTR(5): pointer to the NCV by NCV upper Hessenberg matrix -c H in WORKL. -c IPNTR(6): pointer to the real part of the ritz value array -c RITZR in WORKL. -c IPNTR(7): pointer to the imaginary part of the ritz value array -c RITZI in WORKL. -c IPNTR(8): pointer to the Ritz estimates in array WORKL associated -c with the Ritz values located in RITZR and RITZI in WORKL. -c -c IPNTR(14): pointer to the NP shifts in WORKL. See Remark 5 below. -c -c Note: IPNTR(9:13) is only referenced by sneupd. See Remark 2 below. -c -c IPNTR(9): pointer to the real part of the NCV RITZ values of the -c original system. -c IPNTR(10): pointer to the imaginary part of the NCV RITZ values of -c the original system. -c IPNTR(11): pointer to the NCV corresponding error bounds. -c IPNTR(12): pointer to the NCV by NCV upper quasi-triangular -c Schur matrix for H. -c IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors -c of the upper Hessenberg matrix H. Only referenced by -c sneupd if RVEC = .TRUE. See Remark 2 below. -c ------------------------------------------------------------- -c -c WORKD Real work array of length 3*N. (REVERSE COMMUNICATION) -c Distributed array to be used in the basic Arnoldi iteration -c for reverse communication. The user should not use WORKD -c as temporary workspace during the iteration. Upon termination -c WORKD(1:N) contains B*RESID(1:N). If an invariant subspace -c associated with the converged Ritz values is desired, see remark -c 2 below, subroutine sneupd uses this output. -c See Data Distribution Note below. -c -c WORKL Real work array of length LWORKL. (OUTPUT/WORKSPACE) -c Private (replicated) array on each PE or array allocated on -c the front end. See Data Distribution Note below. -c -c LWORKL Integer. (INPUT) -c LWORKL must be at least 3*NCV**2 + 6*NCV. -c -c INFO Integer. (INPUT/OUTPUT) -c If INFO .EQ. 0, a randomly initial residual vector is used. -c If INFO .NE. 0, RESID contains the initial residual vector, -c possibly from a previous run. -c Error flag on output. -c = 0: Normal exit. -c = 1: Maximum number of iterations taken. -c All possible eigenvalues of OP has been found. IPARAM(5) -c returns the number of wanted converged Ritz values. -c = 2: No longer an informational error. Deprecated starting -c with release 2 of ARPACK. -c = 3: No shifts could be applied during a cycle of the -c Implicitly restarted Arnoldi iteration. One possibility -c is to increase the size of NCV relative to NEV. -c See remark 4 below. -c = -1: N must be positive. -c = -2: NEV must be positive. -c = -3: NCV-NEV >= 2 and less than or equal to N. -c = -4: The maximum number of Arnoldi update iteration -c must be greater than zero. -c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI' -c = -6: BMAT must be one of 'I' or 'G'. -c = -7: Length of private work array is not sufficient. -c = -8: Error return from LAPACK eigenvalue calculation; -c = -9: Starting vector is zero. -c = -10: IPARAM(7) must be 1,2,3,4. -c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatable. -c = -12: IPARAM(1) must be equal to 0 or 1. -c = -9999: Could not build an Arnoldi factorization. -c IPARAM(5) returns the size of the current Arnoldi -c factorization. -c -c\Remarks -c 1. The computed Ritz values are approximate eigenvalues of OP. The -c selection of WHICH should be made with this in mind when -c Mode = 3 and 4. After convergence, approximate eigenvalues of the -c original problem may be obtained with the ARPACK subroutine sneupd. -c -c 2. If a basis for the invariant subspace corresponding to the converged Ritz -c values is needed, the user must call sneupd immediately following -c completion of snaupd. This is new starting with release 2 of ARPACK. -c -c 3. If M can be factored into a Cholesky factorization M = LL` -c then Mode = 2 should not be selected. Instead one should use -c Mode = 1 with OP = inv(L)*A*inv(L`). Appropriate triangular -c linear systems should be solved with L and L` rather -c than computing inverses. After convergence, an approximate -c eigenvector z of the original problem is recovered by solving -c L`z = x where x is a Ritz vector of OP. -c -c 4. At present there is no a-priori analysis to guide the selection -c of NCV relative to NEV. The only formal requrement is that NCV > NEV + 2. -c However, it is recommended that NCV .ge. 2*NEV+1. If many problems of -c the same type are to be solved, one should experiment with increasing -c NCV while keeping NEV fixed for a given test problem. This will -c usually decrease the required number of OP*x operations but it -c also increases the work and storage required to maintain the orthogonal -c basis vectors. The optimal "cross-over" with respect to CPU time -c is problem dependent and must be determined empirically. -c See Chapter 8 of Reference 2 for further information. -c -c 5. When IPARAM(1) = 0, and IDO = 3, the user needs to provide the -c NP = IPARAM(8) real and imaginary parts of the shifts in locations -c real part imaginary part -c ----------------------- -------------- -c 1 WORKL(IPNTR(14)) WORKL(IPNTR(14)+NP) -c 2 WORKL(IPNTR(14)+1) WORKL(IPNTR(14)+NP+1) -c . . -c . . -c . . -c NP WORKL(IPNTR(14)+NP-1) WORKL(IPNTR(14)+2*NP-1). -c -c Only complex conjugate pairs of shifts may be applied and the pairs -c must be placed in consecutive locations. The real part of the -c eigenvalues of the current upper Hessenberg matrix are located in -c WORKL(IPNTR(6)) through WORKL(IPNTR(6)+NCV-1) and the imaginary part -c in WORKL(IPNTR(7)) through WORKL(IPNTR(7)+NCV-1). They are ordered -c according to the order defined by WHICH. The complex conjugate -c pairs are kept together and the associated Ritz estimates are located in -c WORKL(IPNTR(8)), WORKL(IPNTR(8)+1), ... , WORKL(IPNTR(8)+NCV-1). -c -c----------------------------------------------------------------------- -c -c\Data Distribution Note: -c -c Fortran-D syntax: -c ================ -c Real resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) -c decompose d1(n), d2(n,ncv) -c align resid(i) with d1(i) -c align v(i,j) with d2(i,j) -c align workd(i) with d1(i) range (1:n) -c align workd(i) with d1(i-n) range (n+1:2*n) -c align workd(i) with d1(i-2*n) range (2*n+1:3*n) -c distribute d1(block), d2(block,:) -c replicated workl(lworkl) -c -c Cray MPP syntax: -c =============== -c Real resid(n), v(ldv,ncv), workd(n,3), workl(lworkl) -c shared resid(block), v(block,:), workd(block,:) -c replicated workl(lworkl) -c -c CM2/CM5 syntax: -c ============== -c -c----------------------------------------------------------------------- -c -c include 'ex-nonsym.doc' -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Local variables: -c xxxxxx real -c -c\References: -c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in -c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), -c pp 357-385. -c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly -c Restarted Arnoldi Iteration", Rice University Technical Report -c TR95-13, Department of Computational and Applied Mathematics. -c 3. B.N. Parlett & Y. Saad, "Complex Shift and Invert Strategies for -c Real Matrices", Linear Algebra and its Applications, vol 88/89, -c pp 575-595, (1987). -c -c\Routines called: -c snaup2 ARPACK routine that implements the Implicitly Restarted -c Arnoldi Iteration. -c ivout ARPACK utility routine that prints integers. -c arscnd ARPACK utility routine for timing. -c svout ARPACK utility routine that prints vectors. -c slamch LAPACK routine that determines machine constants. -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\Revision history: -c 12/16/93: Version '1.1' -c -c\SCCS Information: @(#) -c FILE: naupd.F SID: 2.8 DATE OF SID: 04/10/01 RELEASE: 2 -c -c\Remarks -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine snaupd - & ( ido, bmat, n, which, nev, tol, resid, ncv, v, ldv, iparam, - & ipntr, workd, workl, lworkl, info ) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - character bmat*1, which*2 - integer ido, info, ldv, lworkl, n, ncv, nev - Real - & tol -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - integer iparam(11), ipntr(14) - Real - & resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) -c -c %------------% -c | Parameters | -c %------------% -c - Real - & one, zero - parameter (one = 1.0E+0 , zero = 0.0E+0 ) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - integer bounds, ierr, ih, iq, ishift, iupd, iw, - & ldh, ldq, levec, mode, msglvl, mxiter, nb, - & nev0, next, np, ritzi, ritzr, j - save bounds, ih, iq, ishift, iupd, iw, ldh, ldq, - & levec, mode, msglvl, mxiter, nb, nev0, next, - & np, ritzi, ritzr -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external snaup2, svout, ivout, arscnd, sstatn -c -c %--------------------% -c | External Functions | -c %--------------------% -c - Real - & slamch - external slamch -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c - if (ido .eq. 0) then -c -c %-------------------------------% -c | Initialize timing statistics | -c | & message level for debugging | -c %-------------------------------% -c - call sstatn - call arscnd (t0) - msglvl = mnaupd -c -c %----------------% -c | Error checking | -c %----------------% -c - ierr = 0 - ishift = iparam(1) -c levec = iparam(2) - mxiter = iparam(3) -c nb = iparam(4) - nb = 1 -c -c %--------------------------------------------% -c | Revision 2 performs only implicit restart. | -c %--------------------------------------------% -c - iupd = 1 - mode = iparam(7) -c - if (n .le. 0) then - ierr = -1 - else if (nev .le. 0) then - ierr = -2 - else if (ncv .le. nev+1 .or. ncv .gt. n) then - ierr = -3 - else if (mxiter .le. 0) then - ierr = -4 - else if (which .ne. 'LM' .and. - & which .ne. 'SM' .and. - & which .ne. 'LR' .and. - & which .ne. 'SR' .and. - & which .ne. 'LI' .and. - & which .ne. 'SI') then - ierr = -5 - else if (bmat .ne. 'I' .and. bmat .ne. 'G') then - ierr = -6 - else if (lworkl .lt. 3*ncv**2 + 6*ncv) then - ierr = -7 - else if (mode .lt. 1 .or. mode .gt. 4) then - ierr = -10 - else if (mode .eq. 1 .and. bmat .eq. 'G') then - ierr = -11 - else if (ishift .lt. 0 .or. ishift .gt. 1) then - ierr = -12 - end if -c -c %------------% -c | Error Exit | -c %------------% -c - if (ierr .ne. 0) then - info = ierr - ido = 99 - go to 9000 - end if -c -c %------------------------% -c | Set default parameters | -c %------------------------% -c - if (nb .le. 0) nb = 1 - if (tol .le. zero) tol = slamch('EpsMach') -c -c %----------------------------------------------% -c | NP is the number of additional steps to | -c | extend the length NEV Lanczos factorization. | -c | NEV0 is the local variable designating the | -c | size of the invariant subspace desired. | -c %----------------------------------------------% -c - np = ncv - nev - nev0 = nev -c -c %-----------------------------% -c | Zero out internal workspace | -c %-----------------------------% -c - do 10 j = 1, 3*ncv**2 + 6*ncv - workl(j) = zero - 10 continue -c -c %-------------------------------------------------------------% -c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | -c | etc... and the remaining workspace. | -c | Also update pointer to be used on output. | -c | Memory is laid out as follows: | -c | workl(1:ncv*ncv) := generated Hessenberg matrix | -c | workl(ncv*ncv+1:ncv*ncv+2*ncv) := real and imaginary | -c | parts of ritz values | -c | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := error bounds | -c | workl(ncv*ncv+3*ncv+1:2*ncv*ncv+3*ncv) := rotation matrix Q | -c | workl(2*ncv*ncv+3*ncv+1:3*ncv*ncv+6*ncv) := workspace | -c | The final workspace is needed by subroutine sneigh called | -c | by snaup2. Subroutine sneigh calls LAPACK routines for | -c | calculating eigenvalues and the last row of the eigenvector | -c | matrix. | -c %-------------------------------------------------------------% -c - ldh = ncv - ldq = ncv - ih = 1 - ritzr = ih + ldh*ncv - ritzi = ritzr + ncv - bounds = ritzi + ncv - iq = bounds + ncv - iw = iq + ldq*ncv - next = iw + ncv**2 + 3*ncv -c - ipntr(4) = next - ipntr(5) = ih - ipntr(6) = ritzr - ipntr(7) = ritzi - ipntr(8) = bounds - ipntr(14) = iw -c - end if -c -c %-------------------------------------------------------% -c | Carry out the Implicitly restarted Arnoldi Iteration. | -c %-------------------------------------------------------% -c - call snaup2 - & ( ido, bmat, n, which, nev0, np, tol, resid, mode, iupd, - & ishift, mxiter, v, ldv, workl(ih), ldh, workl(ritzr), - & workl(ritzi), workl(bounds), workl(iq), ldq, workl(iw), - & ipntr, workd, info ) -c -c %--------------------------------------------------% -c | ido .ne. 99 implies use of reverse communication | -c | to compute operations involving OP or shifts. | -c %--------------------------------------------------% -c - if (ido .eq. 3) iparam(8) = np - if (ido .ne. 99) go to 9000 -c - iparam(3) = mxiter - iparam(5) = np - iparam(9) = nopx - iparam(10) = nbx - iparam(11) = nrorth -c -c %------------------------------------% -c | Exit if there was an informational | -c | error within snaup2. | -c %------------------------------------% -c - if (info .lt. 0) go to 9000 - if (info .eq. 2) info = 3 -c - if (msglvl .gt. 0) then - call ivout (logfil, 1, mxiter, ndigit, - & '_naupd: Number of update iterations taken') - call ivout (logfil, 1, np, ndigit, - & '_naupd: Number of wanted "converged" Ritz values') - call svout (logfil, np, workl(ritzr), ndigit, - & '_naupd: Real part of the final Ritz values') - call svout (logfil, np, workl(ritzi), ndigit, - & '_naupd: Imaginary part of the final Ritz values') - call svout (logfil, np, workl(bounds), ndigit, - & '_naupd: Associated Ritz estimates') - end if -c - call arscnd (t1) - tnaupd = t1 - t0 -c - if (msglvl .gt. 0) then -c -c %--------------------------------------------------------% -c | Version Number & Version Date are defined in version.h | -c %--------------------------------------------------------% -c - write (6,1000) - write (6,1100) mxiter, nopx, nbx, nrorth, nitref, nrstrt, - & tmvopx, tmvbx, tnaupd, tnaup2, tnaitr, titref, - & tgetv0, tneigh, tngets, tnapps, tnconv, trvec - 1000 format (//, - & 5x, '=============================================',/ - & 5x, '= Nonsymmetric implicit Arnoldi update code =',/ - & 5x, '= Version Number: ', ' 2.4' , 21x, ' =',/ - & 5x, '= Version Date: ', ' 07/31/96' , 16x, ' =',/ - & 5x, '=============================================',/ - & 5x, '= Summary of timing statistics =',/ - & 5x, '=============================================',//) - 1100 format ( - & 5x, 'Total number update iterations = ', i5,/ - & 5x, 'Total number of OP*x operations = ', i5,/ - & 5x, 'Total number of B*x operations = ', i5,/ - & 5x, 'Total number of reorthogonalization steps = ', i5,/ - & 5x, 'Total number of iterative refinement steps = ', i5,/ - & 5x, 'Total number of restart steps = ', i5,/ - & 5x, 'Total time in user OP*x operation = ', f12.6,/ - & 5x, 'Total time in user B*x operation = ', f12.6,/ - & 5x, 'Total time in Arnoldi update routine = ', f12.6,/ - & 5x, 'Total time in naup2 routine = ', f12.6,/ - & 5x, 'Total time in basic Arnoldi iteration loop = ', f12.6,/ - & 5x, 'Total time in reorthogonalization phase = ', f12.6,/ - & 5x, 'Total time in (re)start vector generation = ', f12.6,/ - & 5x, 'Total time in Hessenberg eig. subproblem = ', f12.6,/ - & 5x, 'Total time in getting the shifts = ', f12.6,/ - & 5x, 'Total time in applying the shifts = ', f12.6,/ - & 5x, 'Total time in convergence testing = ', f12.6,/ - & 5x, 'Total time in computing final Ritz vectors = ', f12.6/) - end if -c - 9000 continue -c - return -c -c %---------------% -c | End of snaupd | -c %---------------% -c - end
--- a/libcruft/arpack/src/snconv.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,146 +0,0 @@ -c----------------------------------------------------------------------- -c\BeginDoc -c -c\Name: snconv -c -c\Description: -c Convergence testing for the nonsymmetric Arnoldi eigenvalue routine. -c -c\Usage: -c call snconv -c ( N, RITZR, RITZI, BOUNDS, TOL, NCONV ) -c -c\Arguments -c N Integer. (INPUT) -c Number of Ritz values to check for convergence. -c -c RITZR, Real arrays of length N. (INPUT) -c RITZI Real and imaginary parts of the Ritz values to be checked -c for convergence. - -c BOUNDS Real array of length N. (INPUT) -c Ritz estimates for the Ritz values in RITZR and RITZI. -c -c TOL Real scalar. (INPUT) -c Desired backward error for a Ritz value to be considered -c "converged". -c -c NCONV Integer scalar. (OUTPUT) -c Number of "converged" Ritz values. -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Local variables: -c xxxxxx real -c -c\Routines called: -c arscnd ARPACK utility routine for timing. -c slamch LAPACK routine that determines machine constants. -c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\Revision history: -c xx/xx/92: Version ' 2.1' -c -c\SCCS Information: @(#) -c FILE: nconv.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2 -c -c\Remarks -c 1. xxxx -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine snconv (n, ritzr, ritzi, bounds, tol, nconv) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - integer n, nconv - Real - & tol -c -c %-----------------% -c | Array Arguments | -c %-----------------% - - Real - & ritzr(n), ritzi(n), bounds(n) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - integer i - Real - & temp, eps23 -c -c %--------------------% -c | External Functions | -c %--------------------% -c - Real - & slapy2, slamch - external slapy2, slamch - -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c -c %-------------------------------------------------------------% -c | Convergence test: unlike in the symmetric code, I am not | -c | using things like refined error bounds and gap condition | -c | because I don't know the exact equivalent concept. | -c | | -c | Instead the i-th Ritz value is considered "converged" when: | -c | | -c | bounds(i) .le. ( TOL * | ritz | ) | -c | | -c | for some appropriate choice of norm. | -c %-------------------------------------------------------------% -c - call arscnd (t0) -c -c %---------------------------------% -c | Get machine dependent constant. | -c %---------------------------------% -c - eps23 = slamch('Epsilon-Machine') - eps23 = eps23**(2.0E+0 / 3.0E+0) -c - nconv = 0 - do 20 i = 1, n - temp = max( eps23, slapy2( ritzr(i), ritzi(i) ) ) - if (bounds(i) .le. tol*temp) nconv = nconv + 1 - 20 continue -c - call arscnd (t1) - tnconv = tnconv + (t1 - t0) -c - return -c -c %---------------% -c | End of snconv | -c %---------------% -c - end
--- a/libcruft/arpack/src/sneigh.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,314 +0,0 @@ -c----------------------------------------------------------------------- -c\BeginDoc -c -c\Name: sneigh -c -c\Description: -c Compute the eigenvalues of the current upper Hessenberg matrix -c and the corresponding Ritz estimates given the current residual norm. -c -c\Usage: -c call sneigh -c ( RNORM, N, H, LDH, RITZR, RITZI, BOUNDS, Q, LDQ, WORKL, IERR ) -c -c\Arguments -c RNORM Real scalar. (INPUT) -c Residual norm corresponding to the current upper Hessenberg -c matrix H. -c -c N Integer. (INPUT) -c Size of the matrix H. -c -c H Real N by N array. (INPUT) -c H contains the current upper Hessenberg matrix. -c -c LDH Integer. (INPUT) -c Leading dimension of H exactly as declared in the calling -c program. -c -c RITZR, Real arrays of length N. (OUTPUT) -c RITZI On output, RITZR(1:N) (resp. RITZI(1:N)) contains the real -c (respectively imaginary) parts of the eigenvalues of H. -c -c BOUNDS Real array of length N. (OUTPUT) -c On output, BOUNDS contains the Ritz estimates associated with -c the eigenvalues RITZR and RITZI. This is equal to RNORM -c times the last components of the eigenvectors corresponding -c to the eigenvalues in RITZR and RITZI. -c -c Q Real N by N array. (WORKSPACE) -c Workspace needed to store the eigenvectors of H. -c -c LDQ Integer. (INPUT) -c Leading dimension of Q exactly as declared in the calling -c program. -c -c WORKL Real work array of length N**2 + 3*N. (WORKSPACE) -c Private (replicated) array on each PE or array allocated on -c the front end. This is needed to keep the full Schur form -c of H and also in the calculation of the eigenvectors of H. -c -c IERR Integer. (OUTPUT) -c Error exit flag from slaqrb or strevc. -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Local variables: -c xxxxxx real -c -c\Routines called: -c slaqrb ARPACK routine to compute the real Schur form of an -c upper Hessenberg matrix and last row of the Schur vectors. -c arscnd ARPACK utility routine for timing. -c smout ARPACK utility routine that prints matrices -c svout ARPACK utility routine that prints vectors. -c slacpy LAPACK matrix copy routine. -c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. -c strevc LAPACK routine to compute the eigenvectors of a matrix -c in upper quasi-triangular form -c sgemv Level 2 BLAS routine for matrix vector multiplication. -c scopy Level 1 BLAS that copies one vector to another . -c snrm2 Level 1 BLAS that computes the norm of a vector. -c sscal Level 1 BLAS that scales a vector. -c -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\Revision history: -c xx/xx/92: Version ' 2.1' -c -c\SCCS Information: @(#) -c FILE: neigh.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2 -c -c\Remarks -c None -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine sneigh (rnorm, n, h, ldh, ritzr, ritzi, bounds, - & q, ldq, workl, ierr) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - integer ierr, n, ldh, ldq - Real - & rnorm -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - Real - & bounds(n), h(ldh,n), q(ldq,n), ritzi(n), ritzr(n), - & workl(n*(n+3)) -c -c %------------% -c | Parameters | -c %------------% -c - Real - & one, zero - parameter (one = 1.0E+0, zero = 0.0E+0) -c -c %------------------------% -c | Local Scalars & Arrays | -c %------------------------% -c - logical select(1) - integer i, iconj, msglvl - Real - & temp, vl(1) -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external scopy, slacpy, slaqrb, strevc, svout, arscnd -c -c %--------------------% -c | External Functions | -c %--------------------% -c - Real - & slapy2, snrm2 - external slapy2, snrm2 -c -c %---------------------% -c | Intrinsic Functions | -c %---------------------% -c - intrinsic abs -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c -c -c %-------------------------------% -c | Initialize timing statistics | -c | & message level for debugging | -c %-------------------------------% -c - call arscnd (t0) - msglvl = mneigh -c - if (msglvl .gt. 2) then - call smout (logfil, n, n, h, ldh, ndigit, - & '_neigh: Entering upper Hessenberg matrix H ') - end if -c -c %-----------------------------------------------------------% -c | 1. Compute the eigenvalues, the last components of the | -c | corresponding Schur vectors and the full Schur form T | -c | of the current upper Hessenberg matrix H. | -c | slaqrb returns the full Schur form of H in WORKL(1:N**2) | -c | and the last components of the Schur vectors in BOUNDS. | -c %-----------------------------------------------------------% -c - call slacpy ('All', n, n, h, ldh, workl, n) - call slaqrb (.true., n, 1, n, workl, n, ritzr, ritzi, bounds, - & ierr) - if (ierr .ne. 0) go to 9000 -c - if (msglvl .gt. 1) then - call svout (logfil, n, bounds, ndigit, - & '_neigh: last row of the Schur matrix for H') - end if -c -c %-----------------------------------------------------------% -c | 2. Compute the eigenvectors of the full Schur form T and | -c | apply the last components of the Schur vectors to get | -c | the last components of the corresponding eigenvectors. | -c | Remember that if the i-th and (i+1)-st eigenvalues are | -c | complex conjugate pairs, then the real & imaginary part | -c | of the eigenvector components are split across adjacent | -c | columns of Q. | -c %-----------------------------------------------------------% -c - call strevc ('R', 'A', select, n, workl, n, vl, n, q, ldq, - & n, n, workl(n*n+1), ierr) -c - if (ierr .ne. 0) go to 9000 -c -c %------------------------------------------------% -c | Scale the returning eigenvectors so that their | -c | euclidean norms are all one. LAPACK subroutine | -c | strevc returns each eigenvector normalized so | -c | that the element of largest magnitude has | -c | magnitude 1; here the magnitude of a complex | -c | number (x,y) is taken to be |x| + |y|. | -c %------------------------------------------------% -c - iconj = 0 - do 10 i=1, n - if ( abs( ritzi(i) ) .le. zero ) then -c -c %----------------------% -c | Real eigenvalue case | -c %----------------------% -c - temp = snrm2( n, q(1,i), 1 ) - call sscal ( n, one / temp, q(1,i), 1 ) - else -c -c %-------------------------------------------% -c | Complex conjugate pair case. Note that | -c | since the real and imaginary part of | -c | the eigenvector are stored in consecutive | -c | columns, we further normalize by the | -c | square root of two. | -c %-------------------------------------------% -c - if (iconj .eq. 0) then - temp = slapy2( snrm2( n, q(1,i), 1 ), - & snrm2( n, q(1,i+1), 1 ) ) - call sscal ( n, one / temp, q(1,i), 1 ) - call sscal ( n, one / temp, q(1,i+1), 1 ) - iconj = 1 - else - iconj = 0 - end if - end if - 10 continue -c - call sgemv ('T', n, n, one, q, ldq, bounds, 1, zero, workl, 1) -c - if (msglvl .gt. 1) then - call svout (logfil, n, workl, ndigit, - & '_neigh: Last row of the eigenvector matrix for H') - end if -c -c %----------------------------% -c | Compute the Ritz estimates | -c %----------------------------% -c - iconj = 0 - do 20 i = 1, n - if ( abs( ritzi(i) ) .le. zero ) then -c -c %----------------------% -c | Real eigenvalue case | -c %----------------------% -c - bounds(i) = rnorm * abs( workl(i) ) - else -c -c %-------------------------------------------% -c | Complex conjugate pair case. Note that | -c | since the real and imaginary part of | -c | the eigenvector are stored in consecutive | -c | columns, we need to take the magnitude | -c | of the last components of the two vectors | -c %-------------------------------------------% -c - if (iconj .eq. 0) then - bounds(i) = rnorm * slapy2( workl(i), workl(i+1) ) - bounds(i+1) = bounds(i) - iconj = 1 - else - iconj = 0 - end if - end if - 20 continue -c - if (msglvl .gt. 2) then - call svout (logfil, n, ritzr, ndigit, - & '_neigh: Real part of the eigenvalues of H') - call svout (logfil, n, ritzi, ndigit, - & '_neigh: Imaginary part of the eigenvalues of H') - call svout (logfil, n, bounds, ndigit, - & '_neigh: Ritz estimates for the eigenvalues of H') - end if -c - call arscnd (t1) - tneigh = tneigh + (t1 - t0) -c - 9000 continue - return -c -c %---------------% -c | End of sneigh | -c %---------------% -c - end
--- a/libcruft/arpack/src/sneupd.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1067 +0,0 @@ -c\BeginDoc -c -c\Name: sneupd -c -c\Description: -c -c This subroutine returns the converged approximations to eigenvalues -c of A*z = lambda*B*z and (optionally): -c -c (1) The corresponding approximate eigenvectors; -c -c (2) An orthonormal basis for the associated approximate -c invariant subspace; -c -c (3) Both. -c -c There is negligible additional cost to obtain eigenvectors. An orthonormal -c basis is always computed. There is an additional storage cost of n*nev -c if both are requested (in this case a separate array Z must be supplied). -c -c The approximate eigenvalues and eigenvectors of A*z = lambda*B*z -c are derived from approximate eigenvalues and eigenvectors of -c of the linear operator OP prescribed by the MODE selection in the -c call to SNAUPD. SNAUPD must be called before this routine is called. -c These approximate eigenvalues and vectors are commonly called Ritz -c values and Ritz vectors respectively. They are referred to as such -c in the comments that follow. The computed orthonormal basis for the -c invariant subspace corresponding to these Ritz values is referred to as a -c Schur basis. -c -c See documentation in the header of the subroutine SNAUPD for -c definition of OP as well as other terms and the relation of computed -c Ritz values and Ritz vectors of OP with respect to the given problem -c A*z = lambda*B*z. For a brief description, see definitions of -c IPARAM(7), MODE and WHICH in the documentation of SNAUPD. -c -c\Usage: -c call sneupd -c ( RVEC, HOWMNY, SELECT, DR, DI, Z, LDZ, SIGMAR, SIGMAI, WORKEV, BMAT, -c N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, WORKD, WORKL, -c LWORKL, INFO ) -c -c\Arguments: -c RVEC LOGICAL (INPUT) -c Specifies whether a basis for the invariant subspace corresponding -c to the converged Ritz value approximations for the eigenproblem -c A*z = lambda*B*z is computed. -c -c RVEC = .FALSE. Compute Ritz values only. -c -c RVEC = .TRUE. Compute the Ritz vectors or Schur vectors. -c See Remarks below. -c -c HOWMNY Character*1 (INPUT) -c Specifies the form of the basis for the invariant subspace -c corresponding to the converged Ritz values that is to be computed. -c -c = 'A': Compute NEV Ritz vectors; -c = 'P': Compute NEV Schur vectors; -c = 'S': compute some of the Ritz vectors, specified -c by the logical array SELECT. -c -c SELECT Logical array of dimension NCV. (INPUT) -c If HOWMNY = 'S', SELECT specifies the Ritz vectors to be -c computed. To select the Ritz vector corresponding to a -c Ritz value (DR(j), DI(j)), SELECT(j) must be set to .TRUE.. -c If HOWMNY = 'A' or 'P', SELECT is used as internal workspace. -c -c DR Real array of dimension NEV+1. (OUTPUT) -c If IPARAM(7) = 1,2 or 3 and SIGMAI=0.0 then on exit: DR contains -c the real part of the Ritz approximations to the eigenvalues of -c A*z = lambda*B*z. -c If IPARAM(7) = 3, 4 and SIGMAI is not equal to zero, then on exit: -c DR contains the real part of the Ritz values of OP computed by -c SNAUPD. A further computation must be performed by the user -c to transform the Ritz values computed for OP by SNAUPD to those -c of the original system A*z = lambda*B*z. See remark 3 below. -c -c DI Real array of dimension NEV+1. (OUTPUT) -c On exit, DI contains the imaginary part of the Ritz value -c approximations to the eigenvalues of A*z = lambda*B*z associated -c with DR. -c -c NOTE: When Ritz values are complex, they will come in complex -c conjugate pairs. If eigenvectors are requested, the -c corresponding Ritz vectors will also come in conjugate -c pairs and the real and imaginary parts of these are -c represented in two consecutive columns of the array Z -c (see below). -c -c Z Real N by NEV+1 array if RVEC = .TRUE. and HOWMNY = 'A'. (OUTPUT) -c On exit, if RVEC = .TRUE. and HOWMNY = 'A', then the columns of -c Z represent approximate eigenvectors (Ritz vectors) corresponding -c to the NCONV=IPARAM(5) Ritz values for eigensystem -c A*z = lambda*B*z. -c -c The complex Ritz vector associated with the Ritz value -c with positive imaginary part is stored in two consecutive -c columns. The first column holds the real part of the Ritz -c vector and the second column holds the imaginary part. The -c Ritz vector associated with the Ritz value with negative -c imaginary part is simply the complex conjugate of the Ritz vector -c associated with the positive imaginary part. -c -c If RVEC = .FALSE. or HOWMNY = 'P', then Z is not referenced. -c -c NOTE: If if RVEC = .TRUE. and a Schur basis is not required, -c the array Z may be set equal to first NEV+1 columns of the Arnoldi -c basis array V computed by SNAUPD. In this case the Arnoldi basis -c will be destroyed and overwritten with the eigenvector basis. -c -c LDZ Integer. (INPUT) -c The leading dimension of the array Z. If Ritz vectors are -c desired, then LDZ >= max( 1, N ). In any case, LDZ >= 1. -c -c SIGMAR Real (INPUT) -c If IPARAM(7) = 3 or 4, represents the real part of the shift. -c Not referenced if IPARAM(7) = 1 or 2. -c -c SIGMAI Real (INPUT) -c If IPARAM(7) = 3 or 4, represents the imaginary part of the shift. -c Not referenced if IPARAM(7) = 1 or 2. See remark 3 below. -c -c WORKEV Real work array of dimension 3*NCV. (WORKSPACE) -c -c **** The remaining arguments MUST be the same as for the **** -c **** call to SNAUPD that was just completed. **** -c -c NOTE: The remaining arguments -c -c BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, -c WORKD, WORKL, LWORKL, INFO -c -c must be passed directly to SNEUPD following the last call -c to SNAUPD. These arguments MUST NOT BE MODIFIED between -c the the last call to SNAUPD and the call to SNEUPD. -c -c Three of these parameters (V, WORKL, INFO) are also output parameters: -c -c V Real N by NCV array. (INPUT/OUTPUT) -c -c Upon INPUT: the NCV columns of V contain the Arnoldi basis -c vectors for OP as constructed by SNAUPD . -c -c Upon OUTPUT: If RVEC = .TRUE. the first NCONV=IPARAM(5) columns -c contain approximate Schur vectors that span the -c desired invariant subspace. See Remark 2 below. -c -c NOTE: If the array Z has been set equal to first NEV+1 columns -c of the array V and RVEC=.TRUE. and HOWMNY= 'A', then the -c Arnoldi basis held by V has been overwritten by the desired -c Ritz vectors. If a separate array Z has been passed then -c the first NCONV=IPARAM(5) columns of V will contain approximate -c Schur vectors that span the desired invariant subspace. -c -c WORKL Real work array of length LWORKL. (OUTPUT/WORKSPACE) -c WORKL(1:ncv*ncv+3*ncv) contains information obtained in -c snaupd. They are not changed by sneupd. -c WORKL(ncv*ncv+3*ncv+1:3*ncv*ncv+6*ncv) holds the -c real and imaginary part of the untransformed Ritz values, -c the upper quasi-triangular matrix for H, and the -c associated matrix representation of the invariant subspace for H. -c -c Note: IPNTR(9:13) contains the pointer into WORKL for addresses -c of the above information computed by sneupd. -c ------------------------------------------------------------- -c IPNTR(9): pointer to the real part of the NCV RITZ values of the -c original system. -c IPNTR(10): pointer to the imaginary part of the NCV RITZ values of -c the original system. -c IPNTR(11): pointer to the NCV corresponding error bounds. -c IPNTR(12): pointer to the NCV by NCV upper quasi-triangular -c Schur matrix for H. -c IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors -c of the upper Hessenberg matrix H. Only referenced by -c sneupd if RVEC = .TRUE. See Remark 2 below. -c ------------------------------------------------------------- -c -c INFO Integer. (OUTPUT) -c Error flag on output. -c -c = 0: Normal exit. -c -c = 1: The Schur form computed by LAPACK routine slahqr -c could not be reordered by LAPACK routine strsen. -c Re-enter subroutine sneupd with IPARAM(5)=NCV and -c increase the size of the arrays DR and DI to have -c dimension at least dimension NCV and allocate at least NCV -c columns for Z. NOTE: Not necessary if Z and V share -c the same space. Please notify the authors if this error -c occurs. -c -c = -1: N must be positive. -c = -2: NEV must be positive. -c = -3: NCV-NEV >= 2 and less than or equal to N. -c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI' -c = -6: BMAT must be one of 'I' or 'G'. -c = -7: Length of private work WORKL array is not sufficient. -c = -8: Error return from calculation of a real Schur form. -c Informational error from LAPACK routine slahqr. -c = -9: Error return from calculation of eigenvectors. -c Informational error from LAPACK routine strevc. -c = -10: IPARAM(7) must be 1,2,3,4. -c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. -c = -12: HOWMNY = 'S' not yet implemented -c = -13: HOWMNY must be one of 'A' or 'P' if RVEC = .true. -c = -14: SNAUPD did not find any eigenvalues to sufficient -c accuracy. -c = -15: DNEUPD got a different count of the number of converged -c Ritz values than DNAUPD got. This indicates the user -c probably made an error in passing data from DNAUPD to -c DNEUPD or that the data was modified before entering -c DNEUPD -c -c\BeginLib -c -c\References: -c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in -c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), -c pp 357-385. -c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly -c Restarted Arnoldi Iteration", Rice University Technical Report -c TR95-13, Department of Computational and Applied Mathematics. -c 3. B.N. Parlett & Y. Saad, "Complex Shift and Invert Strategies for -c Real Matrices", Linear Algebra and its Applications, vol 88/89, -c pp 575-595, (1987). -c -c\Routines called: -c ivout ARPACK utility routine that prints integers. -c smout ARPACK utility routine that prints matrices -c svout ARPACK utility routine that prints vectors. -c sgeqr2 LAPACK routine that computes the QR factorization of -c a matrix. -c slacpy LAPACK matrix copy routine. -c slahqr LAPACK routine to compute the real Schur form of an -c upper Hessenberg matrix. -c slamch LAPACK routine that determines machine constants. -c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. -c slaset LAPACK matrix initialization routine. -c sorm2r LAPACK routine that applies an orthogonal matrix in -c factored form. -c strevc LAPACK routine to compute the eigenvectors of a matrix -c in upper quasi-triangular form. -c strsen LAPACK routine that re-orders the Schur form. -c strmm Level 3 BLAS matrix times an upper triangular matrix. -c sger Level 2 BLAS rank one update to a matrix. -c scopy Level 1 BLAS that copies one vector to another . -c sdot Level 1 BLAS that computes the scalar product of two vectors. -c snrm2 Level 1 BLAS that computes the norm of a vector. -c sscal Level 1 BLAS that scales a vector. -c -c\Remarks -c -c 1. Currently only HOWMNY = 'A' and 'P' are implemented. -c -c Let trans(X) denote the transpose of X. -c -c 2. Schur vectors are an orthogonal representation for the basis of -c Ritz vectors. Thus, their numerical properties are often superior. -c If RVEC = .TRUE. then the relationship -c A * V(:,1:IPARAM(5)) = V(:,1:IPARAM(5)) * T, and -c trans(V(:,1:IPARAM(5))) * V(:,1:IPARAM(5)) = I are approximately -c satisfied. Here T is the leading submatrix of order IPARAM(5) of the -c real upper quasi-triangular matrix stored workl(ipntr(12)). That is, -c T is block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; -c each 2-by-2 diagonal block has its diagonal elements equal and its -c off-diagonal elements of opposite sign. Corresponding to each 2-by-2 -c diagonal block is a complex conjugate pair of Ritz values. The real -c Ritz values are stored on the diagonal of T. -c -c 3. If IPARAM(7) = 3 or 4 and SIGMAI is not equal zero, then the user must -c form the IPARAM(5) Rayleigh quotients in order to transform the Ritz -c values computed by SNAUPD for OP to those of A*z = lambda*B*z. -c Set RVEC = .true. and HOWMNY = 'A', and -c compute -c trans(Z(:,I)) * A * Z(:,I) if DI(I) = 0. -c If DI(I) is not equal to zero and DI(I+1) = - D(I), -c then the desired real and imaginary parts of the Ritz value are -c trans(Z(:,I)) * A * Z(:,I) + trans(Z(:,I+1)) * A * Z(:,I+1), -c trans(Z(:,I)) * A * Z(:,I+1) - trans(Z(:,I+1)) * A * Z(:,I), -c respectively. -c Another possibility is to set RVEC = .true. and HOWMNY = 'P' and -c compute trans(V(:,1:IPARAM(5))) * A * V(:,1:IPARAM(5)) and then an upper -c quasi-triangular matrix of order IPARAM(5) is computed. See remark -c 2 above. -c -c\Authors -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Chao Yang Houston, Texas -c Dept. of Computational & -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\SCCS Information: @(#) -c FILE: neupd.F SID: 2.7 DATE OF SID: 09/20/00 RELEASE: 2 -c -c\EndLib -c -c----------------------------------------------------------------------- - subroutine sneupd(rvec , howmny, select, dr , di, - & z , ldz , sigmar, sigmai, workev, - & bmat , n , which , nev , tol, - & resid, ncv , v , ldv , iparam, - & ipntr, workd , workl , lworkl, info) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - character bmat, howmny, which*2 - logical rvec - integer info, ldz, ldv, lworkl, n, ncv, nev - Real - & sigmar, sigmai, tol -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - integer iparam(11), ipntr(14) - logical select(ncv) - Real - & dr(nev+1) , di(nev+1), resid(n) , - & v(ldv,ncv) , z(ldz,*) , workd(3*n), - & workl(lworkl), workev(3*ncv) -c -c %------------% -c | Parameters | -c %------------% -c - Real - & one, zero - parameter (one = 1.0E+0 , zero = 0.0E+0 ) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - character type*6 - integer bounds, ierr , ih , ihbds , - & iheigr, iheigi, iconj , nconv , - & invsub, iuptri, iwev , iwork(1), - & j , k , ldh , ldq , - & mode , msglvl, outncv, ritzr , - & ritzi , wri , wrr , irr , - & iri , ibd , ishift, numcnv , - & np , jj , nconv2 - logical reord - Real - & conds , rnorm, sep , temp, - & vl(1,1), temp1, eps23 -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external scopy , sger , sgeqr2, slacpy, - & slahqr, slaset, smout , sorm2r, - & strevc, strmm , strsen, sscal , - & svout , ivout -c -c %--------------------% -c | External Functions | -c %--------------------% -c - Real - & slapy2, snrm2, slamch, sdot - external slapy2, snrm2, slamch, sdot -c -c %---------------------% -c | Intrinsic Functions | -c %---------------------% -c - intrinsic abs, min, sqrt -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c -c %------------------------% -c | Set default parameters | -c %------------------------% -c - msglvl = mneupd - mode = iparam(7) - nconv = iparam(5) - info = 0 -c -c %---------------------------------% -c | Get machine dependent constant. | -c %---------------------------------% -c - eps23 = slamch('Epsilon-Machine') - eps23 = eps23**(2.0E+0 / 3.0E+0 ) -c -c %--------------% -c | Quick return | -c %--------------% -c - ierr = 0 -c - if (nconv .le. 0) then - ierr = -14 - else if (n .le. 0) then - ierr = -1 - else if (nev .le. 0) then - ierr = -2 - else if (ncv .le. nev+1 .or. ncv .gt. n) then - ierr = -3 - else if (which .ne. 'LM' .and. - & which .ne. 'SM' .and. - & which .ne. 'LR' .and. - & which .ne. 'SR' .and. - & which .ne. 'LI' .and. - & which .ne. 'SI') then - ierr = -5 - else if (bmat .ne. 'I' .and. bmat .ne. 'G') then - ierr = -6 - else if (lworkl .lt. 3*ncv**2 + 6*ncv) then - ierr = -7 - else if ( (howmny .ne. 'A' .and. - & howmny .ne. 'P' .and. - & howmny .ne. 'S') .and. rvec ) then - ierr = -13 - else if (howmny .eq. 'S' ) then - ierr = -12 - end if -c - if (mode .eq. 1 .or. mode .eq. 2) then - type = 'REGULR' - else if (mode .eq. 3 .and. sigmai .eq. zero) then - type = 'SHIFTI' - else if (mode .eq. 3 ) then - type = 'REALPT' - else if (mode .eq. 4 ) then - type = 'IMAGPT' - else - ierr = -10 - end if - if (mode .eq. 1 .and. bmat .eq. 'G') ierr = -11 -c -c %------------% -c | Error Exit | -c %------------% -c - if (ierr .ne. 0) then - info = ierr - go to 9000 - end if -c -c %--------------------------------------------------------% -c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | -c | etc... and the remaining workspace. | -c | Also update pointer to be used on output. | -c | Memory is laid out as follows: | -c | workl(1:ncv*ncv) := generated Hessenberg matrix | -c | workl(ncv*ncv+1:ncv*ncv+2*ncv) := real and imaginary | -c | parts of ritz values | -c | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := error bounds | -c %--------------------------------------------------------% -c -c %-----------------------------------------------------------% -c | The following is used and set by SNEUPD. | -c | workl(ncv*ncv+3*ncv+1:ncv*ncv+4*ncv) := The untransformed | -c | real part of the Ritz values. | -c | workl(ncv*ncv+4*ncv+1:ncv*ncv+5*ncv) := The untransformed | -c | imaginary part of the Ritz values. | -c | workl(ncv*ncv+5*ncv+1:ncv*ncv+6*ncv) := The untransformed | -c | error bounds of the Ritz values | -c | workl(ncv*ncv+6*ncv+1:2*ncv*ncv+6*ncv) := Holds the upper | -c | quasi-triangular matrix for H | -c | workl(2*ncv*ncv+6*ncv+1: 3*ncv*ncv+6*ncv) := Holds the | -c | associated matrix representation of the invariant | -c | subspace for H. | -c | GRAND total of NCV * ( 3 * NCV + 6 ) locations. | -c %-----------------------------------------------------------% -c - ih = ipntr(5) - ritzr = ipntr(6) - ritzi = ipntr(7) - bounds = ipntr(8) - ldh = ncv - ldq = ncv - iheigr = bounds + ldh - iheigi = iheigr + ldh - ihbds = iheigi + ldh - iuptri = ihbds + ldh - invsub = iuptri + ldh*ncv - ipntr(9) = iheigr - ipntr(10) = iheigi - ipntr(11) = ihbds - ipntr(12) = iuptri - ipntr(13) = invsub - wrr = 1 - wri = ncv + 1 - iwev = wri + ncv -c -c %-----------------------------------------% -c | irr points to the REAL part of the Ritz | -c | values computed by _neigh before | -c | exiting _naup2. | -c | iri points to the IMAGINARY part of the | -c | Ritz values computed by _neigh | -c | before exiting _naup2. | -c | ibd points to the Ritz estimates | -c | computed by _neigh before exiting | -c | _naup2. | -c %-----------------------------------------% -c - irr = ipntr(14)+ncv*ncv - iri = irr+ncv - ibd = iri+ncv -c -c %------------------------------------% -c | RNORM is B-norm of the RESID(1:N). | -c %------------------------------------% -c - rnorm = workl(ih+2) - workl(ih+2) = zero -c - if (msglvl .gt. 2) then - call svout(logfil, ncv, workl(irr), ndigit, - & '_neupd: Real part of Ritz values passed in from _NAUPD.') - call svout(logfil, ncv, workl(iri), ndigit, - & '_neupd: Imag part of Ritz values passed in from _NAUPD.') - call svout(logfil, ncv, workl(ibd), ndigit, - & '_neupd: Ritz estimates passed in from _NAUPD.') - end if -c - if (rvec) then -c - reord = .false. -c -c %---------------------------------------------------% -c | Use the temporary bounds array to store indices | -c | These will be used to mark the select array later | -c %---------------------------------------------------% -c - do 10 j = 1,ncv - workl(bounds+j-1) = j - select(j) = .false. - 10 continue -c -c %-------------------------------------% -c | Select the wanted Ritz values. | -c | Sort the Ritz values so that the | -c | wanted ones appear at the tailing | -c | NEV positions of workl(irr) and | -c | workl(iri). Move the corresponding | -c | error estimates in workl(bound) | -c | accordingly. | -c %-------------------------------------% -c - np = ncv - nev - ishift = 0 - call sngets(ishift , which , nev , - & np , workl(irr), workl(iri), - & workl(bounds), workl , workl(np+1)) -c - if (msglvl .gt. 2) then - call svout(logfil, ncv, workl(irr), ndigit, - & '_neupd: Real part of Ritz values after calling _NGETS.') - call svout(logfil, ncv, workl(iri), ndigit, - & '_neupd: Imag part of Ritz values after calling _NGETS.') - call svout(logfil, ncv, workl(bounds), ndigit, - & '_neupd: Ritz value indices after calling _NGETS.') - end if -c -c %-----------------------------------------------------% -c | Record indices of the converged wanted Ritz values | -c | Mark the select array for possible reordering | -c %-----------------------------------------------------% -c - numcnv = 0 - do 11 j = 1,ncv - temp1 = max(eps23, - & slapy2( workl(irr+ncv-j), workl(iri+ncv-j) )) - jj = workl(bounds + ncv - j) - if (numcnv .lt. nconv .and. - & workl(ibd+jj-1) .le. tol*temp1) then - select(jj) = .true. - numcnv = numcnv + 1 - if (jj .gt. nev) reord = .true. - endif - 11 continue -c -c %-----------------------------------------------------------% -c | Check the count (numcnv) of converged Ritz values with | -c | the number (nconv) reported by dnaupd. If these two | -c | are different then there has probably been an error | -c | caused by incorrect passing of the dnaupd data. | -c %-----------------------------------------------------------% -c - if (msglvl .gt. 2) then - call ivout(logfil, 1, numcnv, ndigit, - & '_neupd: Number of specified eigenvalues') - call ivout(logfil, 1, nconv, ndigit, - & '_neupd: Number of "converged" eigenvalues') - end if -c - if (numcnv .ne. nconv) then - info = -15 - go to 9000 - end if -c -c %-----------------------------------------------------------% -c | Call LAPACK routine slahqr to compute the real Schur form | -c | of the upper Hessenberg matrix returned by SNAUPD. | -c | Make a copy of the upper Hessenberg matrix. | -c | Initialize the Schur vector matrix Q to the identity. | -c %-----------------------------------------------------------% -c - call scopy(ldh*ncv, workl(ih), 1, workl(iuptri), 1) - call slaset('All', ncv, ncv, - & zero , one, workl(invsub), - & ldq) - call slahqr(.true., .true. , ncv, - & 1 , ncv , workl(iuptri), - & ldh , workl(iheigr), workl(iheigi), - & 1 , ncv , workl(invsub), - & ldq , ierr) - call scopy(ncv , workl(invsub+ncv-1), ldq, - & workl(ihbds), 1) -c - if (ierr .ne. 0) then - info = -8 - go to 9000 - end if -c - if (msglvl .gt. 1) then - call svout(logfil, ncv, workl(iheigr), ndigit, - & '_neupd: Real part of the eigenvalues of H') - call svout(logfil, ncv, workl(iheigi), ndigit, - & '_neupd: Imaginary part of the Eigenvalues of H') - call svout(logfil, ncv, workl(ihbds), ndigit, - & '_neupd: Last row of the Schur vector matrix') - if (msglvl .gt. 3) then - call smout(logfil , ncv, ncv , - & workl(iuptri), ldh, ndigit, - & '_neupd: The upper quasi-triangular matrix ') - end if - end if -c - if (reord) then -c -c %-----------------------------------------------------% -c | Reorder the computed upper quasi-triangular matrix. | -c %-----------------------------------------------------% -c - call strsen('None' , 'V' , - & select , ncv , - & workl(iuptri), ldh , - & workl(invsub), ldq , - & workl(iheigr), workl(iheigi), - & nconv2 , conds , - & sep , workl(ihbds) , - & ncv , iwork , - & 1 , ierr) -c - if (nconv2 .lt. nconv) then - nconv = nconv2 - end if - - if (ierr .eq. 1) then - info = 1 - go to 9000 - end if -c - if (msglvl .gt. 2) then - call svout(logfil, ncv, workl(iheigr), ndigit, - & '_neupd: Real part of the eigenvalues of H--reordered') - call svout(logfil, ncv, workl(iheigi), ndigit, - & '_neupd: Imag part of the eigenvalues of H--reordered') - if (msglvl .gt. 3) then - call smout(logfil , ncv, ncv , - & workl(iuptri), ldq, ndigit, - & '_neupd: Quasi-triangular matrix after re-ordering') - end if - end if -c - end if -c -c %---------------------------------------% -c | Copy the last row of the Schur vector | -c | into workl(ihbds). This will be used | -c | to compute the Ritz estimates of | -c | converged Ritz values. | -c %---------------------------------------% -c - call scopy(ncv, workl(invsub+ncv-1), ldq, workl(ihbds), 1) -c -c %----------------------------------------------------% -c | Place the computed eigenvalues of H into DR and DI | -c | if a spectral transformation was not used. | -c %----------------------------------------------------% -c - if (type .eq. 'REGULR') then - call scopy(nconv, workl(iheigr), 1, dr, 1) - call scopy(nconv, workl(iheigi), 1, di, 1) - end if -c -c %----------------------------------------------------------% -c | Compute the QR factorization of the matrix representing | -c | the wanted invariant subspace located in the first NCONV | -c | columns of workl(invsub,ldq). | -c %----------------------------------------------------------% -c - call sgeqr2(ncv, nconv , workl(invsub), - & ldq, workev, workev(ncv+1), - & ierr) -c -c %---------------------------------------------------------% -c | * Postmultiply V by Q using sorm2r. | -c | * Copy the first NCONV columns of VQ into Z. | -c | * Postmultiply Z by R. | -c | The N by NCONV matrix Z is now a matrix representation | -c | of the approximate invariant subspace associated with | -c | the Ritz values in workl(iheigr) and workl(iheigi) | -c | The first NCONV columns of V are now approximate Schur | -c | vectors associated with the real upper quasi-triangular | -c | matrix of order NCONV in workl(iuptri) | -c %---------------------------------------------------------% -c - call sorm2r('Right', 'Notranspose', n , - & ncv , nconv , workl(invsub), - & ldq , workev , v , - & ldv , workd(n+1) , ierr) - call slacpy('All', n, nconv, v, ldv, z, ldz) -c - do 20 j=1, nconv -c -c %---------------------------------------------------% -c | Perform both a column and row scaling if the | -c | diagonal element of workl(invsub,ldq) is negative | -c | I'm lazy and don't take advantage of the upper | -c | quasi-triangular form of workl(iuptri,ldq) | -c | Note that since Q is orthogonal, R is a diagonal | -c | matrix consisting of plus or minus ones | -c %---------------------------------------------------% -c - if (workl(invsub+(j-1)*ldq+j-1) .lt. zero) then - call sscal(nconv, -one, workl(iuptri+j-1), ldq) - call sscal(nconv, -one, workl(iuptri+(j-1)*ldq), 1) - end if -c - 20 continue -c - if (howmny .eq. 'A') then -c -c %--------------------------------------------% -c | Compute the NCONV wanted eigenvectors of T | -c | located in workl(iuptri,ldq). | -c %--------------------------------------------% -c - do 30 j=1, ncv - if (j .le. nconv) then - select(j) = .true. - else - select(j) = .false. - end if - 30 continue -c - call strevc('Right', 'Select' , select , - & ncv , workl(iuptri), ldq , - & vl , 1 , workl(invsub), - & ldq , ncv , outncv , - & workev , ierr) -c - if (ierr .ne. 0) then - info = -9 - go to 9000 - end if -c -c %------------------------------------------------% -c | Scale the returning eigenvectors so that their | -c | Euclidean norms are all one. LAPACK subroutine | -c | strevc returns each eigenvector normalized so | -c | that the element of largest magnitude has | -c | magnitude 1; | -c %------------------------------------------------% -c - iconj = 0 - do 40 j=1, nconv -c - if ( workl(iheigi+j-1) .eq. zero ) then -c -c %----------------------% -c | real eigenvalue case | -c %----------------------% -c - temp = snrm2( ncv, workl(invsub+(j-1)*ldq), 1 ) - call sscal( ncv, one / temp, - & workl(invsub+(j-1)*ldq), 1 ) -c - else -c -c %-------------------------------------------% -c | Complex conjugate pair case. Note that | -c | since the real and imaginary part of | -c | the eigenvector are stored in consecutive | -c | columns, we further normalize by the | -c | square root of two. | -c %-------------------------------------------% -c - if (iconj .eq. 0) then - temp = slapy2(snrm2(ncv, - & workl(invsub+(j-1)*ldq), - & 1), - & snrm2(ncv, - & workl(invsub+j*ldq), - & 1)) - call sscal(ncv, one/temp, - & workl(invsub+(j-1)*ldq), 1 ) - call sscal(ncv, one/temp, - & workl(invsub+j*ldq), 1 ) - iconj = 1 - else - iconj = 0 - end if -c - end if -c - 40 continue -c - call sgemv('T', ncv, nconv, one, workl(invsub), - & ldq, workl(ihbds), 1, zero, workev, 1) -c - iconj = 0 - do 45 j=1, nconv - if (workl(iheigi+j-1) .ne. zero) then -c -c %-------------------------------------------% -c | Complex conjugate pair case. Note that | -c | since the real and imaginary part of | -c | the eigenvector are stored in consecutive | -c %-------------------------------------------% -c - if (iconj .eq. 0) then - workev(j) = slapy2(workev(j), workev(j+1)) - workev(j+1) = workev(j) - iconj = 1 - else - iconj = 0 - end if - end if - 45 continue -c - if (msglvl .gt. 2) then - call scopy(ncv, workl(invsub+ncv-1), ldq, - & workl(ihbds), 1) - call svout(logfil, ncv, workl(ihbds), ndigit, - & '_neupd: Last row of the eigenvector matrix for T') - if (msglvl .gt. 3) then - call smout(logfil, ncv, ncv, workl(invsub), ldq, - & ndigit, '_neupd: The eigenvector matrix for T') - end if - end if -c -c %---------------------------------------% -c | Copy Ritz estimates into workl(ihbds) | -c %---------------------------------------% -c - call scopy(nconv, workev, 1, workl(ihbds), 1) -c -c %---------------------------------------------------------% -c | Compute the QR factorization of the eigenvector matrix | -c | associated with leading portion of T in the first NCONV | -c | columns of workl(invsub,ldq). | -c %---------------------------------------------------------% -c - call sgeqr2(ncv, nconv , workl(invsub), - & ldq, workev, workev(ncv+1), - & ierr) -c -c %----------------------------------------------% -c | * Postmultiply Z by Q. | -c | * Postmultiply Z by R. | -c | The N by NCONV matrix Z is now contains the | -c | Ritz vectors associated with the Ritz values | -c | in workl(iheigr) and workl(iheigi). | -c %----------------------------------------------% -c - call sorm2r('Right', 'Notranspose', n , - & ncv , nconv , workl(invsub), - & ldq , workev , z , - & ldz , workd(n+1) , ierr) -c - call strmm('Right' , 'Upper' , 'No transpose', - & 'Non-unit', n , nconv , - & one , workl(invsub), ldq , - & z , ldz) -c - end if -c - else -c -c %------------------------------------------------------% -c | An approximate invariant subspace is not needed. | -c | Place the Ritz values computed SNAUPD into DR and DI | -c %------------------------------------------------------% -c - call scopy(nconv, workl(ritzr), 1, dr, 1) - call scopy(nconv, workl(ritzi), 1, di, 1) - call scopy(nconv, workl(ritzr), 1, workl(iheigr), 1) - call scopy(nconv, workl(ritzi), 1, workl(iheigi), 1) - call scopy(nconv, workl(bounds), 1, workl(ihbds), 1) - end if -c -c %------------------------------------------------% -c | Transform the Ritz values and possibly vectors | -c | and corresponding error bounds of OP to those | -c | of A*x = lambda*B*x. | -c %------------------------------------------------% -c - if (type .eq. 'REGULR') then -c - if (rvec) - & call sscal(ncv, rnorm, workl(ihbds), 1) -c - else -c -c %---------------------------------------% -c | A spectral transformation was used. | -c | * Determine the Ritz estimates of the | -c | Ritz values in the original system. | -c %---------------------------------------% -c - if (type .eq. 'SHIFTI') then -c - if (rvec) - & call sscal(ncv, rnorm, workl(ihbds), 1) -c - do 50 k=1, ncv - temp = slapy2( workl(iheigr+k-1), - & workl(iheigi+k-1) ) - workl(ihbds+k-1) = abs( workl(ihbds+k-1) ) - & / temp / temp - 50 continue -c - else if (type .eq. 'REALPT') then -c - do 60 k=1, ncv - 60 continue -c - else if (type .eq. 'IMAGPT') then -c - do 70 k=1, ncv - 70 continue -c - end if -c -c %-----------------------------------------------------------% -c | * Transform the Ritz values back to the original system. | -c | For TYPE = 'SHIFTI' the transformation is | -c | lambda = 1/theta + sigma | -c | For TYPE = 'REALPT' or 'IMAGPT' the user must from | -c | Rayleigh quotients or a projection. See remark 3 above.| -c | NOTES: | -c | *The Ritz vectors are not affected by the transformation. | -c %-----------------------------------------------------------% -c - if (type .eq. 'SHIFTI') then -c - do 80 k=1, ncv - temp = slapy2( workl(iheigr+k-1), - & workl(iheigi+k-1) ) - workl(iheigr+k-1) = workl(iheigr+k-1)/temp/temp - & + sigmar - workl(iheigi+k-1) = -workl(iheigi+k-1)/temp/temp - & + sigmai - 80 continue -c - call scopy(nconv, workl(iheigr), 1, dr, 1) - call scopy(nconv, workl(iheigi), 1, di, 1) -c - else if (type .eq. 'REALPT' .or. type .eq. 'IMAGPT') then -c - call scopy(nconv, workl(iheigr), 1, dr, 1) - call scopy(nconv, workl(iheigi), 1, di, 1) -c - end if -c - end if -c - if (type .eq. 'SHIFTI' .and. msglvl .gt. 1) then - call svout(logfil, nconv, dr, ndigit, - & '_neupd: Untransformed real part of the Ritz valuess.') - call svout (logfil, nconv, di, ndigit, - & '_neupd: Untransformed imag part of the Ritz valuess.') - call svout(logfil, nconv, workl(ihbds), ndigit, - & '_neupd: Ritz estimates of untransformed Ritz values.') - else if (type .eq. 'REGULR' .and. msglvl .gt. 1) then - call svout(logfil, nconv, dr, ndigit, - & '_neupd: Real parts of converged Ritz values.') - call svout (logfil, nconv, di, ndigit, - & '_neupd: Imag parts of converged Ritz values.') - call svout(logfil, nconv, workl(ihbds), ndigit, - & '_neupd: Associated Ritz estimates.') - end if -c -c %-------------------------------------------------% -c | Eigenvector Purification step. Formally perform | -c | one of inverse subspace iteration. Only used | -c | for MODE = 2. | -c %-------------------------------------------------% -c - if (rvec .and. howmny .eq. 'A' .and. type .eq. 'SHIFTI') then -c -c %------------------------------------------------% -c | Purify the computed Ritz vectors by adding a | -c | little bit of the residual vector: | -c | T | -c | resid(:)*( e s ) / theta | -c | NCV | -c | where H s = s theta. Remember that when theta | -c | has nonzero imaginary part, the corresponding | -c | Ritz vector is stored across two columns of Z. | -c %------------------------------------------------% -c - iconj = 0 - do 110 j=1, nconv - if (workl(iheigi+j-1) .eq. zero) then - workev(j) = workl(invsub+(j-1)*ldq+ncv-1) / - & workl(iheigr+j-1) - else if (iconj .eq. 0) then - temp = slapy2( workl(iheigr+j-1), workl(iheigi+j-1) ) - workev(j) = ( workl(invsub+(j-1)*ldq+ncv-1) * - & workl(iheigr+j-1) + - & workl(invsub+j*ldq+ncv-1) * - & workl(iheigi+j-1) ) / temp / temp - workev(j+1) = ( workl(invsub+j*ldq+ncv-1) * - & workl(iheigr+j-1) - - & workl(invsub+(j-1)*ldq+ncv-1) * - & workl(iheigi+j-1) ) / temp / temp - iconj = 1 - else - iconj = 0 - end if - 110 continue -c -c %---------------------------------------% -c | Perform a rank one update to Z and | -c | purify all the Ritz vectors together. | -c %---------------------------------------% -c - call sger(n, nconv, one, resid, 1, workev, 1, z, ldz) -c - end if -c - 9000 continue -c - return -c -c %---------------% -c | End of SNEUPD | -c %---------------% -c - end
--- a/libcruft/arpack/src/sngets.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,231 +0,0 @@ -c----------------------------------------------------------------------- -c\BeginDoc -c -c\Name: sngets -c -c\Description: -c Given the eigenvalues of the upper Hessenberg matrix H, -c computes the NP shifts AMU that are zeros of the polynomial of -c degree NP which filters out components of the unwanted eigenvectors -c corresponding to the AMU's based on some given criteria. -c -c NOTE: call this even in the case of user specified shifts in order -c to sort the eigenvalues, and error bounds of H for later use. -c -c\Usage: -c call sngets -c ( ISHIFT, WHICH, KEV, NP, RITZR, RITZI, BOUNDS, SHIFTR, SHIFTI ) -c -c\Arguments -c ISHIFT Integer. (INPUT) -c Method for selecting the implicit shifts at each iteration. -c ISHIFT = 0: user specified shifts -c ISHIFT = 1: exact shift with respect to the matrix H. -c -c WHICH Character*2. (INPUT) -c Shift selection criteria. -c 'LM' -> want the KEV eigenvalues of largest magnitude. -c 'SM' -> want the KEV eigenvalues of smallest magnitude. -c 'LR' -> want the KEV eigenvalues of largest real part. -c 'SR' -> want the KEV eigenvalues of smallest real part. -c 'LI' -> want the KEV eigenvalues of largest imaginary part. -c 'SI' -> want the KEV eigenvalues of smallest imaginary part. -c -c KEV Integer. (INPUT/OUTPUT) -c INPUT: KEV+NP is the size of the matrix H. -c OUTPUT: Possibly increases KEV by one to keep complex conjugate -c pairs together. -c -c NP Integer. (INPUT/OUTPUT) -c Number of implicit shifts to be computed. -c OUTPUT: Possibly decreases NP by one to keep complex conjugate -c pairs together. -c -c RITZR, Real array of length KEV+NP. (INPUT/OUTPUT) -c RITZI On INPUT, RITZR and RITZI contain the real and imaginary -c parts of the eigenvalues of H. -c On OUTPUT, RITZR and RITZI are sorted so that the unwanted -c eigenvalues are in the first NP locations and the wanted -c portion is in the last KEV locations. When exact shifts are -c selected, the unwanted part corresponds to the shifts to -c be applied. Also, if ISHIFT .eq. 1, the unwanted eigenvalues -c are further sorted so that the ones with largest Ritz values -c are first. -c -c BOUNDS Real array of length KEV+NP. (INPUT/OUTPUT) -c Error bounds corresponding to the ordering in RITZ. -c -c SHIFTR, SHIFTI *** USE deprecated as of version 2.1. *** -c -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Local variables: -c xxxxxx real -c -c\Routines called: -c ssortc ARPACK sorting routine. -c scopy Level 1 BLAS that copies one vector to another . -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\Revision history: -c xx/xx/92: Version ' 2.1' -c -c\SCCS Information: @(#) -c FILE: ngets.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2 -c -c\Remarks -c 1. xxxx -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine sngets ( ishift, which, kev, np, ritzr, ritzi, bounds, - & shiftr, shifti ) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - character*2 which - integer ishift, kev, np -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - Real - & bounds(kev+np), ritzr(kev+np), ritzi(kev+np), - & shiftr(1), shifti(1) -c -c %------------% -c | Parameters | -c %------------% -c - Real - & one, zero - parameter (one = 1.0, zero = 0.0) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - integer msglvl -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external scopy, ssortc, arscnd -c -c %----------------------% -c | Intrinsics Functions | -c %----------------------% -c - intrinsic abs -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c -c %-------------------------------% -c | Initialize timing statistics | -c | & message level for debugging | -c %-------------------------------% -c - call arscnd (t0) - msglvl = mngets -c -c %----------------------------------------------------% -c | LM, SM, LR, SR, LI, SI case. | -c | Sort the eigenvalues of H into the desired order | -c | and apply the resulting order to BOUNDS. | -c | The eigenvalues are sorted so that the wanted part | -c | are always in the last KEV locations. | -c | We first do a pre-processing sort in order to keep | -c | complex conjugate pairs together | -c %----------------------------------------------------% -c - if (which .eq. 'LM') then - call ssortc ('LR', .true., kev+np, ritzr, ritzi, bounds) - else if (which .eq. 'SM') then - call ssortc ('SR', .true., kev+np, ritzr, ritzi, bounds) - else if (which .eq. 'LR') then - call ssortc ('LM', .true., kev+np, ritzr, ritzi, bounds) - else if (which .eq. 'SR') then - call ssortc ('SM', .true., kev+np, ritzr, ritzi, bounds) - else if (which .eq. 'LI') then - call ssortc ('LM', .true., kev+np, ritzr, ritzi, bounds) - else if (which .eq. 'SI') then - call ssortc ('SM', .true., kev+np, ritzr, ritzi, bounds) - end if -c - call ssortc (which, .true., kev+np, ritzr, ritzi, bounds) -c -c %-------------------------------------------------------% -c | Increase KEV by one if the ( ritzr(np),ritzi(np) ) | -c | = ( ritzr(np+1),-ritzi(np+1) ) and ritz(np) .ne. zero | -c | Accordingly decrease NP by one. In other words keep | -c | complex conjugate pairs together. | -c %-------------------------------------------------------% -c - if ( ( ritzr(np+1) - ritzr(np) ) .eq. zero - & .and. ( ritzi(np+1) + ritzi(np) ) .eq. zero ) then - np = np - 1 - kev = kev + 1 - end if -c - if ( ishift .eq. 1 ) then -c -c %-------------------------------------------------------% -c | Sort the unwanted Ritz values used as shifts so that | -c | the ones with largest Ritz estimates are first | -c | This will tend to minimize the effects of the | -c | forward instability of the iteration when they shifts | -c | are applied in subroutine snapps. | -c | Be careful and use 'SR' since we want to sort BOUNDS! | -c %-------------------------------------------------------% -c - call ssortc ( 'SR', .true., np, bounds, ritzr, ritzi ) - end if -c - call arscnd (t1) - tngets = tngets + (t1 - t0) -c - if (msglvl .gt. 0) then - call ivout (logfil, 1, kev, ndigit, '_ngets: KEV is') - call ivout (logfil, 1, np, ndigit, '_ngets: NP is') - call svout (logfil, kev+np, ritzr, ndigit, - & '_ngets: Eigenvalues of current H matrix -- real part') - call svout (logfil, kev+np, ritzi, ndigit, - & '_ngets: Eigenvalues of current H matrix -- imag part') - call svout (logfil, kev+np, bounds, ndigit, - & '_ngets: Ritz estimates of the current KEV+NP Ritz values') - end if -c - return -c -c %---------------% -c | End of sngets | -c %---------------% -c - end
--- a/libcruft/arpack/src/ssaitr.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,853 +0,0 @@ -c----------------------------------------------------------------------- -c\BeginDoc -c -c\Name: ssaitr -c -c\Description: -c Reverse communication interface for applying NP additional steps to -c a K step symmetric Arnoldi factorization. -c -c Input: OP*V_{k} - V_{k}*H = r_{k}*e_{k}^T -c -c with (V_{k}^T)*B*V_{k} = I, (V_{k}^T)*B*r_{k} = 0. -c -c Output: OP*V_{k+p} - V_{k+p}*H = r_{k+p}*e_{k+p}^T -c -c with (V_{k+p}^T)*B*V_{k+p} = I, (V_{k+p}^T)*B*r_{k+p} = 0. -c -c where OP and B are as in ssaupd. The B-norm of r_{k+p} is also -c computed and returned. -c -c\Usage: -c call ssaitr -c ( IDO, BMAT, N, K, NP, MODE, RESID, RNORM, V, LDV, H, LDH, -c IPNTR, WORKD, INFO ) -c -c\Arguments -c IDO Integer. (INPUT/OUTPUT) -c Reverse communication flag. -c ------------------------------------------------------------- -c IDO = 0: first call to the reverse communication interface -c IDO = -1: compute Y = OP * X where -c IPNTR(1) is the pointer into WORK for X, -c IPNTR(2) is the pointer into WORK for Y. -c This is for the restart phase to force the new -c starting vector into the range of OP. -c IDO = 1: compute Y = OP * X where -c IPNTR(1) is the pointer into WORK for X, -c IPNTR(2) is the pointer into WORK for Y, -c IPNTR(3) is the pointer into WORK for B * X. -c IDO = 2: compute Y = B * X where -c IPNTR(1) is the pointer into WORK for X, -c IPNTR(2) is the pointer into WORK for Y. -c IDO = 99: done -c ------------------------------------------------------------- -c When the routine is used in the "shift-and-invert" mode, the -c vector B * Q is already available and does not need to be -c recomputed in forming OP * Q. -c -c BMAT Character*1. (INPUT) -c BMAT specifies the type of matrix B that defines the -c semi-inner product for the operator OP. See ssaupd. -c B = 'I' -> standard eigenvalue problem A*x = lambda*x -c B = 'G' -> generalized eigenvalue problem A*x = lambda*M*x -c -c N Integer. (INPUT) -c Dimension of the eigenproblem. -c -c K Integer. (INPUT) -c Current order of H and the number of columns of V. -c -c NP Integer. (INPUT) -c Number of additional Arnoldi steps to take. -c -c MODE Integer. (INPUT) -c Signifies which form for "OP". If MODE=2 then -c a reduction in the number of B matrix vector multiplies -c is possible since the B-norm of OP*x is equivalent to -c the inv(B)-norm of A*x. -c -c RESID Real array of length N. (INPUT/OUTPUT) -c On INPUT: RESID contains the residual vector r_{k}. -c On OUTPUT: RESID contains the residual vector r_{k+p}. -c -c RNORM Real scalar. (INPUT/OUTPUT) -c On INPUT the B-norm of r_{k}. -c On OUTPUT the B-norm of the updated residual r_{k+p}. -c -c V Real N by K+NP array. (INPUT/OUTPUT) -c On INPUT: V contains the Arnoldi vectors in the first K -c columns. -c On OUTPUT: V contains the new NP Arnoldi vectors in the next -c NP columns. The first K columns are unchanged. -c -c LDV Integer. (INPUT) -c Leading dimension of V exactly as declared in the calling -c program. -c -c H Real (K+NP) by 2 array. (INPUT/OUTPUT) -c H is used to store the generated symmetric tridiagonal matrix -c with the subdiagonal in the first column starting at H(2,1) -c and the main diagonal in the second column. -c -c LDH Integer. (INPUT) -c Leading dimension of H exactly as declared in the calling -c program. -c -c IPNTR Integer array of length 3. (OUTPUT) -c Pointer to mark the starting locations in the WORK for -c vectors used by the Arnoldi iteration. -c ------------------------------------------------------------- -c IPNTR(1): pointer to the current operand vector X. -c IPNTR(2): pointer to the current result vector Y. -c IPNTR(3): pointer to the vector B * X when used in the -c shift-and-invert mode. X is the current operand. -c ------------------------------------------------------------- -c -c WORKD Real work array of length 3*N. (REVERSE COMMUNICATION) -c Distributed array to be used in the basic Arnoldi iteration -c for reverse communication. The calling program should not -c use WORKD as temporary workspace during the iteration !!!!!! -c On INPUT, WORKD(1:N) = B*RESID where RESID is associated -c with the K step Arnoldi factorization. Used to save some -c computation at the first step. -c On OUTPUT, WORKD(1:N) = B*RESID where RESID is associated -c with the K+NP step Arnoldi factorization. -c -c INFO Integer. (OUTPUT) -c = 0: Normal exit. -c > 0: Size of an invariant subspace of OP is found that is -c less than K + NP. -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Local variables: -c xxxxxx real -c -c\Routines called: -c sgetv0 ARPACK routine to generate the initial vector. -c ivout ARPACK utility routine that prints integers. -c smout ARPACK utility routine that prints matrices. -c svout ARPACK utility routine that prints vectors. -c slamch LAPACK routine that determines machine constants. -c slascl LAPACK routine for careful scaling of a matrix. -c sgemv Level 2 BLAS routine for matrix vector multiplication. -c saxpy Level 1 BLAS that computes a vector triad. -c sscal Level 1 BLAS that scales a vector. -c scopy Level 1 BLAS that copies one vector to another . -c sdot Level 1 BLAS that computes the scalar product of two vectors. -c snrm2 Level 1 BLAS that computes the norm of a vector. -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\Revision history: -c xx/xx/93: Version ' 2.4' -c -c\SCCS Information: @(#) -c FILE: saitr.F SID: 2.6 DATE OF SID: 8/28/96 RELEASE: 2 -c -c\Remarks -c The algorithm implemented is: -c -c restart = .false. -c Given V_{k} = [v_{1}, ..., v_{k}], r_{k}; -c r_{k} contains the initial residual vector even for k = 0; -c Also assume that rnorm = || B*r_{k} || and B*r_{k} are already -c computed by the calling program. -c -c betaj = rnorm ; p_{k+1} = B*r_{k} ; -c For j = k+1, ..., k+np Do -c 1) if ( betaj < tol ) stop or restart depending on j. -c if ( restart ) generate a new starting vector. -c 2) v_{j} = r(j-1)/betaj; V_{j} = [V_{j-1}, v_{j}]; -c p_{j} = p_{j}/betaj -c 3) r_{j} = OP*v_{j} where OP is defined as in ssaupd -c For shift-invert mode p_{j} = B*v_{j} is already available. -c wnorm = || OP*v_{j} || -c 4) Compute the j-th step residual vector. -c w_{j} = V_{j}^T * B * OP * v_{j} -c r_{j} = OP*v_{j} - V_{j} * w_{j} -c alphaj <- j-th component of w_{j} -c rnorm = || r_{j} || -c betaj+1 = rnorm -c If (rnorm > 0.717*wnorm) accept step and go back to 1) -c 5) Re-orthogonalization step: -c s = V_{j}'*B*r_{j} -c r_{j} = r_{j} - V_{j}*s; rnorm1 = || r_{j} || -c alphaj = alphaj + s_{j}; -c 6) Iterative refinement step: -c If (rnorm1 > 0.717*rnorm) then -c rnorm = rnorm1 -c accept step and go back to 1) -c Else -c rnorm = rnorm1 -c If this is the first time in step 6), go to 5) -c Else r_{j} lies in the span of V_{j} numerically. -c Set r_{j} = 0 and rnorm = 0; go to 1) -c EndIf -c End Do -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine ssaitr - & (ido, bmat, n, k, np, mode, resid, rnorm, v, ldv, h, ldh, - & ipntr, workd, info) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - character bmat*1 - integer ido, info, k, ldh, ldv, n, mode, np - Real - & rnorm -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - integer ipntr(3) - Real - & h(ldh,2), resid(n), v(ldv,k+np), workd(3*n) -c -c %------------% -c | Parameters | -c %------------% -c - Real - & one, zero - parameter (one = 1.0E+0, zero = 0.0E+0) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - logical first, orth1, orth2, rstart, step3, step4 - integer i, ierr, ipj, irj, ivj, iter, itry, j, msglvl, - & infol, jj - Real - & rnorm1, wnorm, safmin, temp1 - save orth1, orth2, rstart, step3, step4, - & ierr, ipj, irj, ivj, iter, itry, j, msglvl, - & rnorm1, safmin, wnorm -c -c %-----------------------% -c | Local Array Arguments | -c %-----------------------% -c - Real - & xtemp(2) -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external saxpy, scopy, sscal, sgemv, sgetv0, svout, smout, - & slascl, ivout, arscnd -c -c %--------------------% -c | External Functions | -c %--------------------% -c - Real - & sdot, snrm2, slamch - external sdot, snrm2, slamch -c -c %-----------------% -c | Data statements | -c %-----------------% -c - data first / .true. / -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c - if (first) then - first = .false. -c -c %--------------------------------% -c | safmin = safe minimum is such | -c | that 1/sfmin does not overflow | -c %--------------------------------% -c - safmin = slamch('safmin') - end if -c - if (ido .eq. 0) then -c -c %-------------------------------% -c | Initialize timing statistics | -c | & message level for debugging | -c %-------------------------------% -c - call arscnd (t0) - msglvl = msaitr -c -c %------------------------------% -c | Initial call to this routine | -c %------------------------------% -c - info = 0 - step3 = .false. - step4 = .false. - rstart = .false. - orth1 = .false. - orth2 = .false. -c -c %--------------------------------% -c | Pointer to the current step of | -c | the factorization to build | -c %--------------------------------% -c - j = k + 1 -c -c %------------------------------------------% -c | Pointers used for reverse communication | -c | when using WORKD. | -c %------------------------------------------% -c - ipj = 1 - irj = ipj + n - ivj = irj + n - end if -c -c %-------------------------------------------------% -c | When in reverse communication mode one of: | -c | STEP3, STEP4, ORTH1, ORTH2, RSTART | -c | will be .true. | -c | STEP3: return from computing OP*v_{j}. | -c | STEP4: return from computing B-norm of OP*v_{j} | -c | ORTH1: return from computing B-norm of r_{j+1} | -c | ORTH2: return from computing B-norm of | -c | correction to the residual vector. | -c | RSTART: return from OP computations needed by | -c | sgetv0. | -c %-------------------------------------------------% -c - if (step3) go to 50 - if (step4) go to 60 - if (orth1) go to 70 - if (orth2) go to 90 - if (rstart) go to 30 -c -c %------------------------------% -c | Else this is the first step. | -c %------------------------------% -c -c %--------------------------------------------------------------% -c | | -c | A R N O L D I I T E R A T I O N L O O P | -c | | -c | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) | -c %--------------------------------------------------------------% -c - 1000 continue -c - if (msglvl .gt. 2) then - call ivout (logfil, 1, j, ndigit, - & '_saitr: generating Arnoldi vector no.') - call svout (logfil, 1, rnorm, ndigit, - & '_saitr: B-norm of the current residual =') - end if -c -c %---------------------------------------------------------% -c | Check for exact zero. Equivalent to determing whether a | -c | j-step Arnoldi factorization is present. | -c %---------------------------------------------------------% -c - if (rnorm .gt. zero) go to 40 -c -c %---------------------------------------------------% -c | Invariant subspace found, generate a new starting | -c | vector which is orthogonal to the current Arnoldi | -c | basis and continue the iteration. | -c %---------------------------------------------------% -c - if (msglvl .gt. 0) then - call ivout (logfil, 1, j, ndigit, - & '_saitr: ****** restart at step ******') - end if -c -c %---------------------------------------------% -c | ITRY is the loop variable that controls the | -c | maximum amount of times that a restart is | -c | attempted. NRSTRT is used by stat.h | -c %---------------------------------------------% -c - nrstrt = nrstrt + 1 - itry = 1 - 20 continue - rstart = .true. - ido = 0 - 30 continue -c -c %--------------------------------------% -c | If in reverse communication mode and | -c | RSTART = .true. flow returns here. | -c %--------------------------------------% -c - call sgetv0 (ido, bmat, itry, .false., n, j, v, ldv, - & resid, rnorm, ipntr, workd, ierr) - if (ido .ne. 99) go to 9000 - if (ierr .lt. 0) then - itry = itry + 1 - if (itry .le. 3) go to 20 -c -c %------------------------------------------------% -c | Give up after several restart attempts. | -c | Set INFO to the size of the invariant subspace | -c | which spans OP and exit. | -c %------------------------------------------------% -c - info = j - 1 - call arscnd (t1) - tsaitr = tsaitr + (t1 - t0) - ido = 99 - go to 9000 - end if -c - 40 continue -c -c %---------------------------------------------------------% -c | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm | -c | Note that p_{j} = B*r_{j-1}. In order to avoid overflow | -c | when reciprocating a small RNORM, test against lower | -c | machine bound. | -c %---------------------------------------------------------% -c - call scopy (n, resid, 1, v(1,j), 1) - if (rnorm .ge. safmin) then - temp1 = one / rnorm - call sscal (n, temp1, v(1,j), 1) - call sscal (n, temp1, workd(ipj), 1) - else -c -c %-----------------------------------------% -c | To scale both v_{j} and p_{j} carefully | -c | use LAPACK routine SLASCL | -c %-----------------------------------------% -c - call slascl ('General', i, i, rnorm, one, n, 1, - & v(1,j), n, infol) - call slascl ('General', i, i, rnorm, one, n, 1, - & workd(ipj), n, infol) - end if -c -c %------------------------------------------------------% -c | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} | -c | Note that this is not quite yet r_{j}. See STEP 4 | -c %------------------------------------------------------% -c - step3 = .true. - nopx = nopx + 1 - call arscnd (t2) - call scopy (n, v(1,j), 1, workd(ivj), 1) - ipntr(1) = ivj - ipntr(2) = irj - ipntr(3) = ipj - ido = 1 -c -c %-----------------------------------% -c | Exit in order to compute OP*v_{j} | -c %-----------------------------------% -c - go to 9000 - 50 continue -c -c %-----------------------------------% -c | Back from reverse communication; | -c | WORKD(IRJ:IRJ+N-1) := OP*v_{j}. | -c %-----------------------------------% -c - call arscnd (t3) - tmvopx = tmvopx + (t3 - t2) -c - step3 = .false. -c -c %------------------------------------------% -c | Put another copy of OP*v_{j} into RESID. | -c %------------------------------------------% -c - call scopy (n, workd(irj), 1, resid, 1) -c -c %-------------------------------------------% -c | STEP 4: Finish extending the symmetric | -c | Arnoldi to length j. If MODE = 2 | -c | then B*OP = B*inv(B)*A = A and | -c | we don't need to compute B*OP. | -c | NOTE: If MODE = 2 WORKD(IVJ:IVJ+N-1) is | -c | assumed to have A*v_{j}. | -c %-------------------------------------------% -c - if (mode .eq. 2) go to 65 - call arscnd (t2) - if (bmat .eq. 'G') then - nbx = nbx + 1 - step4 = .true. - ipntr(1) = irj - ipntr(2) = ipj - ido = 2 -c -c %-------------------------------------% -c | Exit in order to compute B*OP*v_{j} | -c %-------------------------------------% -c - go to 9000 - else if (bmat .eq. 'I') then - call scopy(n, resid, 1 , workd(ipj), 1) - end if - 60 continue -c -c %-----------------------------------% -c | Back from reverse communication; | -c | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j}. | -c %-----------------------------------% -c - if (bmat .eq. 'G') then - call arscnd (t3) - tmvbx = tmvbx + (t3 - t2) - end if -c - step4 = .false. -c -c %-------------------------------------% -c | The following is needed for STEP 5. | -c | Compute the B-norm of OP*v_{j}. | -c %-------------------------------------% -c - 65 continue - if (mode .eq. 2) then -c -c %----------------------------------% -c | Note that the B-norm of OP*v_{j} | -c | is the inv(B)-norm of A*v_{j}. | -c %----------------------------------% -c - wnorm = sdot (n, resid, 1, workd(ivj), 1) - wnorm = sqrt(abs(wnorm)) - else if (bmat .eq. 'G') then - wnorm = sdot (n, resid, 1, workd(ipj), 1) - wnorm = sqrt(abs(wnorm)) - else if (bmat .eq. 'I') then - wnorm = snrm2(n, resid, 1) - end if -c -c %-----------------------------------------% -c | Compute the j-th residual corresponding | -c | to the j step factorization. | -c | Use Classical Gram Schmidt and compute: | -c | w_{j} <- V_{j}^T * B * OP * v_{j} | -c | r_{j} <- OP*v_{j} - V_{j} * w_{j} | -c %-----------------------------------------% -c -c -c %------------------------------------------% -c | Compute the j Fourier coefficients w_{j} | -c | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. | -c %------------------------------------------% -c - if (mode .ne. 2 ) then - call sgemv('T', n, j, one, v, ldv, workd(ipj), 1, zero, - & workd(irj), 1) - else if (mode .eq. 2) then - call sgemv('T', n, j, one, v, ldv, workd(ivj), 1, zero, - & workd(irj), 1) - end if -c -c %--------------------------------------% -c | Orthgonalize r_{j} against V_{j}. | -c | RESID contains OP*v_{j}. See STEP 3. | -c %--------------------------------------% -c - call sgemv('N', n, j, -one, v, ldv, workd(irj), 1, one, - & resid, 1) -c -c %--------------------------------------% -c | Extend H to have j rows and columns. | -c %--------------------------------------% -c - h(j,2) = workd(irj + j - 1) - if (j .eq. 1 .or. rstart) then - h(j,1) = zero - else - h(j,1) = rnorm - end if - call arscnd (t4) -c - orth1 = .true. - iter = 0 -c - call arscnd (t2) - if (bmat .eq. 'G') then - nbx = nbx + 1 - call scopy (n, resid, 1, workd(irj), 1) - ipntr(1) = irj - ipntr(2) = ipj - ido = 2 -c -c %----------------------------------% -c | Exit in order to compute B*r_{j} | -c %----------------------------------% -c - go to 9000 - else if (bmat .eq. 'I') then - call scopy (n, resid, 1, workd(ipj), 1) - end if - 70 continue -c -c %---------------------------------------------------% -c | Back from reverse communication if ORTH1 = .true. | -c | WORKD(IPJ:IPJ+N-1) := B*r_{j}. | -c %---------------------------------------------------% -c - if (bmat .eq. 'G') then - call arscnd (t3) - tmvbx = tmvbx + (t3 - t2) - end if -c - orth1 = .false. -c -c %------------------------------% -c | Compute the B-norm of r_{j}. | -c %------------------------------% -c - if (bmat .eq. 'G') then - rnorm = sdot (n, resid, 1, workd(ipj), 1) - rnorm = sqrt(abs(rnorm)) - else if (bmat .eq. 'I') then - rnorm = snrm2(n, resid, 1) - end if -c -c %-----------------------------------------------------------% -c | STEP 5: Re-orthogonalization / Iterative refinement phase | -c | Maximum NITER_ITREF tries. | -c | | -c | s = V_{j}^T * B * r_{j} | -c | r_{j} = r_{j} - V_{j}*s | -c | alphaj = alphaj + s_{j} | -c | | -c | The stopping criteria used for iterative refinement is | -c | discussed in Parlett's book SEP, page 107 and in Gragg & | -c | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. | -c | Determine if we need to correct the residual. The goal is | -c | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || | -c %-----------------------------------------------------------% -c - if (rnorm .gt. 0.717*wnorm) go to 100 - nrorth = nrorth + 1 -c -c %---------------------------------------------------% -c | Enter the Iterative refinement phase. If further | -c | refinement is necessary, loop back here. The loop | -c | variable is ITER. Perform a step of Classical | -c | Gram-Schmidt using all the Arnoldi vectors V_{j} | -c %---------------------------------------------------% -c - 80 continue -c - if (msglvl .gt. 2) then - xtemp(1) = wnorm - xtemp(2) = rnorm - call svout (logfil, 2, xtemp, ndigit, - & '_saitr: re-orthonalization ; wnorm and rnorm are') - end if -c -c %----------------------------------------------------% -c | Compute V_{j}^T * B * r_{j}. | -c | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). | -c %----------------------------------------------------% -c - call sgemv ('T', n, j, one, v, ldv, workd(ipj), 1, - & zero, workd(irj), 1) -c -c %----------------------------------------------% -c | Compute the correction to the residual: | -c | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). | -c | The correction to H is v(:,1:J)*H(1:J,1:J) + | -c | v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j, but only | -c | H(j,j) is updated. | -c %----------------------------------------------% -c - call sgemv ('N', n, j, -one, v, ldv, workd(irj), 1, - & one, resid, 1) -c - if (j .eq. 1 .or. rstart) h(j,1) = zero - h(j,2) = h(j,2) + workd(irj + j - 1) -c - orth2 = .true. - call arscnd (t2) - if (bmat .eq. 'G') then - nbx = nbx + 1 - call scopy (n, resid, 1, workd(irj), 1) - ipntr(1) = irj - ipntr(2) = ipj - ido = 2 -c -c %-----------------------------------% -c | Exit in order to compute B*r_{j}. | -c | r_{j} is the corrected residual. | -c %-----------------------------------% -c - go to 9000 - else if (bmat .eq. 'I') then - call scopy (n, resid, 1, workd(ipj), 1) - end if - 90 continue -c -c %---------------------------------------------------% -c | Back from reverse communication if ORTH2 = .true. | -c %---------------------------------------------------% -c - if (bmat .eq. 'G') then - call arscnd (t3) - tmvbx = tmvbx + (t3 - t2) - end if -c -c %-----------------------------------------------------% -c | Compute the B-norm of the corrected residual r_{j}. | -c %-----------------------------------------------------% -c - if (bmat .eq. 'G') then - rnorm1 = sdot (n, resid, 1, workd(ipj), 1) - rnorm1 = sqrt(abs(rnorm1)) - else if (bmat .eq. 'I') then - rnorm1 = snrm2(n, resid, 1) - end if -c - if (msglvl .gt. 0 .and. iter .gt. 0) then - call ivout (logfil, 1, j, ndigit, - & '_saitr: Iterative refinement for Arnoldi residual') - if (msglvl .gt. 2) then - xtemp(1) = rnorm - xtemp(2) = rnorm1 - call svout (logfil, 2, xtemp, ndigit, - & '_saitr: iterative refinement ; rnorm and rnorm1 are') - end if - end if -c -c %-----------------------------------------% -c | Determine if we need to perform another | -c | step of re-orthogonalization. | -c %-----------------------------------------% -c - if (rnorm1 .gt. 0.717*rnorm) then -c -c %--------------------------------% -c | No need for further refinement | -c %--------------------------------% -c - rnorm = rnorm1 -c - else -c -c %-------------------------------------------% -c | Another step of iterative refinement step | -c | is required. NITREF is used by stat.h | -c %-------------------------------------------% -c - nitref = nitref + 1 - rnorm = rnorm1 - iter = iter + 1 - if (iter .le. 1) go to 80 -c -c %-------------------------------------------------% -c | Otherwise RESID is numerically in the span of V | -c %-------------------------------------------------% -c - do 95 jj = 1, n - resid(jj) = zero - 95 continue - rnorm = zero - end if -c -c %----------------------------------------------% -c | Branch here directly if iterative refinement | -c | wasn't necessary or after at most NITER_REF | -c | steps of iterative refinement. | -c %----------------------------------------------% -c - 100 continue -c - rstart = .false. - orth2 = .false. -c - call arscnd (t5) - titref = titref + (t5 - t4) -c -c %----------------------------------------------------------% -c | Make sure the last off-diagonal element is non negative | -c | If not perform a similarity transformation on H(1:j,1:j) | -c | and scale v(:,j) by -1. | -c %----------------------------------------------------------% -c - if (h(j,1) .lt. zero) then - h(j,1) = -h(j,1) - if ( j .lt. k+np) then - call sscal(n, -one, v(1,j+1), 1) - else - call sscal(n, -one, resid, 1) - end if - end if -c -c %------------------------------------% -c | STEP 6: Update j = j+1; Continue | -c %------------------------------------% -c - j = j + 1 - if (j .gt. k+np) then - call arscnd (t1) - tsaitr = tsaitr + (t1 - t0) - ido = 99 -c - if (msglvl .gt. 1) then - call svout (logfil, k+np, h(1,2), ndigit, - & '_saitr: main diagonal of matrix H of step K+NP.') - if (k+np .gt. 1) then - call svout (logfil, k+np-1, h(2,1), ndigit, - & '_saitr: sub diagonal of matrix H of step K+NP.') - end if - end if -c - go to 9000 - end if -c -c %--------------------------------------------------------% -c | Loop back to extend the factorization by another step. | -c %--------------------------------------------------------% -c - go to 1000 -c -c %---------------------------------------------------------------% -c | | -c | E N D O F M A I N I T E R A T I O N L O O P | -c | | -c %---------------------------------------------------------------% -c - 9000 continue - return -c -c %---------------% -c | End of ssaitr | -c %---------------% -c - end
--- a/libcruft/arpack/src/ssapps.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,516 +0,0 @@ -c----------------------------------------------------------------------- -c\BeginDoc -c -c\Name: ssapps -c -c\Description: -c Given the Arnoldi factorization -c -c A*V_{k} - V_{k}*H_{k} = r_{k+p}*e_{k+p}^T, -c -c apply NP shifts implicitly resulting in -c -c A*(V_{k}*Q) - (V_{k}*Q)*(Q^T* H_{k}*Q) = r_{k+p}*e_{k+p}^T * Q -c -c where Q is an orthogonal matrix of order KEV+NP. Q is the product of -c rotations resulting from the NP bulge chasing sweeps. The updated Arnoldi -c factorization becomes: -c -c A*VNEW_{k} - VNEW_{k}*HNEW_{k} = rnew_{k}*e_{k}^T. -c -c\Usage: -c call ssapps -c ( N, KEV, NP, SHIFT, V, LDV, H, LDH, RESID, Q, LDQ, WORKD ) -c -c\Arguments -c N Integer. (INPUT) -c Problem size, i.e. dimension of matrix A. -c -c KEV Integer. (INPUT) -c INPUT: KEV+NP is the size of the input matrix H. -c OUTPUT: KEV is the size of the updated matrix HNEW. -c -c NP Integer. (INPUT) -c Number of implicit shifts to be applied. -c -c SHIFT Real array of length NP. (INPUT) -c The shifts to be applied. -c -c V Real N by (KEV+NP) array. (INPUT/OUTPUT) -c INPUT: V contains the current KEV+NP Arnoldi vectors. -c OUTPUT: VNEW = V(1:n,1:KEV); the updated Arnoldi vectors -c are in the first KEV columns of V. -c -c LDV Integer. (INPUT) -c Leading dimension of V exactly as declared in the calling -c program. -c -c H Real (KEV+NP) by 2 array. (INPUT/OUTPUT) -c INPUT: H contains the symmetric tridiagonal matrix of the -c Arnoldi factorization with the subdiagonal in the 1st column -c starting at H(2,1) and the main diagonal in the 2nd column. -c OUTPUT: H contains the updated tridiagonal matrix in the -c KEV leading submatrix. -c -c LDH Integer. (INPUT) -c Leading dimension of H exactly as declared in the calling -c program. -c -c RESID Real array of length (N). (INPUT/OUTPUT) -c INPUT: RESID contains the the residual vector r_{k+p}. -c OUTPUT: RESID is the updated residual vector rnew_{k}. -c -c Q Real KEV+NP by KEV+NP work array. (WORKSPACE) -c Work array used to accumulate the rotations during the bulge -c chase sweep. -c -c LDQ Integer. (INPUT) -c Leading dimension of Q exactly as declared in the calling -c program. -c -c WORKD Real work array of length 2*N. (WORKSPACE) -c Distributed array used in the application of the accumulated -c orthogonal matrix Q. -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Local variables: -c xxxxxx real -c -c\References: -c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in -c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), -c pp 357-385. -c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly -c Restarted Arnoldi Iteration", Rice University Technical Report -c TR95-13, Department of Computational and Applied Mathematics. -c -c\Routines called: -c ivout ARPACK utility routine that prints integers. -c arscnd ARPACK utility routine for timing. -c svout ARPACK utility routine that prints vectors. -c slamch LAPACK routine that determines machine constants. -c slartg LAPACK Givens rotation construction routine. -c slacpy LAPACK matrix copy routine. -c slaset LAPACK matrix initialization routine. -c sgemv Level 2 BLAS routine for matrix vector multiplication. -c saxpy Level 1 BLAS that computes a vector triad. -c scopy Level 1 BLAS that copies one vector to another. -c sscal Level 1 BLAS that scales a vector. -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\Revision history: -c 12/16/93: Version ' 2.4' -c -c\SCCS Information: @(#) -c FILE: sapps.F SID: 2.6 DATE OF SID: 3/28/97 RELEASE: 2 -c -c\Remarks -c 1. In this version, each shift is applied to all the subblocks of -c the tridiagonal matrix H and not just to the submatrix that it -c comes from. This routine assumes that the subdiagonal elements -c of H that are stored in h(1:kev+np,1) are nonegative upon input -c and enforce this condition upon output. This version incorporates -c deflation. See code for documentation. -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine ssapps - & ( n, kev, np, shift, v, ldv, h, ldh, resid, q, ldq, workd ) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - integer kev, ldh, ldq, ldv, n, np -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - Real - & h(ldh,2), q(ldq,kev+np), resid(n), shift(np), - & v(ldv,kev+np), workd(2*n) -c -c %------------% -c | Parameters | -c %------------% -c - Real - & one, zero - parameter (one = 1.0E+0, zero = 0.0E+0) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - integer i, iend, istart, itop, j, jj, kplusp, msglvl - logical first - Real - & a1, a2, a3, a4, big, c, epsmch, f, g, r, s - save epsmch, first -c -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external saxpy, scopy, sscal, slacpy, slartg, slaset, svout, - & ivout, arscnd, sgemv -c -c %--------------------% -c | External Functions | -c %--------------------% -c - Real - & slamch - external slamch -c -c %----------------------% -c | Intrinsics Functions | -c %----------------------% -c - intrinsic abs -c -c %----------------% -c | Data statments | -c %----------------% -c - data first / .true. / -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c - if (first) then - epsmch = slamch('Epsilon-Machine') - first = .false. - end if - itop = 1 -c -c %-------------------------------% -c | Initialize timing statistics | -c | & message level for debugging | -c %-------------------------------% -c - call arscnd (t0) - msglvl = msapps -c - kplusp = kev + np -c -c %----------------------------------------------% -c | Initialize Q to the identity matrix of order | -c | kplusp used to accumulate the rotations. | -c %----------------------------------------------% -c - call slaset ('All', kplusp, kplusp, zero, one, q, ldq) -c -c %----------------------------------------------% -c | Quick return if there are no shifts to apply | -c %----------------------------------------------% -c - if (np .eq. 0) go to 9000 -c -c %----------------------------------------------------------% -c | Apply the np shifts implicitly. Apply each shift to the | -c | whole matrix and not just to the submatrix from which it | -c | comes. | -c %----------------------------------------------------------% -c - do 90 jj = 1, np -c - istart = itop -c -c %----------------------------------------------------------% -c | Check for splitting and deflation. Currently we consider | -c | an off-diagonal element h(i+1,1) negligible if | -c | h(i+1,1) .le. epsmch*( |h(i,2)| + |h(i+1,2)| ) | -c | for i=1:KEV+NP-1. | -c | If above condition tests true then we set h(i+1,1) = 0. | -c | Note that h(1:KEV+NP,1) are assumed to be non negative. | -c %----------------------------------------------------------% -c - 20 continue -c -c %------------------------------------------------% -c | The following loop exits early if we encounter | -c | a negligible off diagonal element. | -c %------------------------------------------------% -c - do 30 i = istart, kplusp-1 - big = abs(h(i,2)) + abs(h(i+1,2)) - if (h(i+1,1) .le. epsmch*big) then - if (msglvl .gt. 0) then - call ivout (logfil, 1, i, ndigit, - & '_sapps: deflation at row/column no.') - call ivout (logfil, 1, jj, ndigit, - & '_sapps: occured before shift number.') - call svout (logfil, 1, h(i+1,1), ndigit, - & '_sapps: the corresponding off diagonal element') - end if - h(i+1,1) = zero - iend = i - go to 40 - end if - 30 continue - iend = kplusp - 40 continue -c - if (istart .lt. iend) then -c -c %--------------------------------------------------------% -c | Construct the plane rotation G'(istart,istart+1,theta) | -c | that attempts to drive h(istart+1,1) to zero. | -c %--------------------------------------------------------% -c - f = h(istart,2) - shift(jj) - g = h(istart+1,1) - call slartg (f, g, c, s, r) -c -c %-------------------------------------------------------% -c | Apply rotation to the left and right of H; | -c | H <- G' * H * G, where G = G(istart,istart+1,theta). | -c | This will create a "bulge". | -c %-------------------------------------------------------% -c - a1 = c*h(istart,2) + s*h(istart+1,1) - a2 = c*h(istart+1,1) + s*h(istart+1,2) - a4 = c*h(istart+1,2) - s*h(istart+1,1) - a3 = c*h(istart+1,1) - s*h(istart,2) - h(istart,2) = c*a1 + s*a2 - h(istart+1,2) = c*a4 - s*a3 - h(istart+1,1) = c*a3 + s*a4 -c -c %----------------------------------------------------% -c | Accumulate the rotation in the matrix Q; Q <- Q*G | -c %----------------------------------------------------% -c - do 60 j = 1, min(istart+jj,kplusp) - a1 = c*q(j,istart) + s*q(j,istart+1) - q(j,istart+1) = - s*q(j,istart) + c*q(j,istart+1) - q(j,istart) = a1 - 60 continue -c -c -c %----------------------------------------------% -c | The following loop chases the bulge created. | -c | Note that the previous rotation may also be | -c | done within the following loop. But it is | -c | kept separate to make the distinction among | -c | the bulge chasing sweeps and the first plane | -c | rotation designed to drive h(istart+1,1) to | -c | zero. | -c %----------------------------------------------% -c - do 70 i = istart+1, iend-1 -c -c %----------------------------------------------% -c | Construct the plane rotation G'(i,i+1,theta) | -c | that zeros the i-th bulge that was created | -c | by G(i-1,i,theta). g represents the bulge. | -c %----------------------------------------------% -c - f = h(i,1) - g = s*h(i+1,1) -c -c %----------------------------------% -c | Final update with G(i-1,i,theta) | -c %----------------------------------% -c - h(i+1,1) = c*h(i+1,1) - call slartg (f, g, c, s, r) -c -c %-------------------------------------------% -c | The following ensures that h(1:iend-1,1), | -c | the first iend-2 off diagonal of elements | -c | H, remain non negative. | -c %-------------------------------------------% -c - if (r .lt. zero) then - r = -r - c = -c - s = -s - end if -c -c %--------------------------------------------% -c | Apply rotation to the left and right of H; | -c | H <- G * H * G', where G = G(i,i+1,theta) | -c %--------------------------------------------% -c - h(i,1) = r -c - a1 = c*h(i,2) + s*h(i+1,1) - a2 = c*h(i+1,1) + s*h(i+1,2) - a3 = c*h(i+1,1) - s*h(i,2) - a4 = c*h(i+1,2) - s*h(i+1,1) -c - h(i,2) = c*a1 + s*a2 - h(i+1,2) = c*a4 - s*a3 - h(i+1,1) = c*a3 + s*a4 -c -c %----------------------------------------------------% -c | Accumulate the rotation in the matrix Q; Q <- Q*G | -c %----------------------------------------------------% -c - do 50 j = 1, min( i+jj, kplusp ) - a1 = c*q(j,i) + s*q(j,i+1) - q(j,i+1) = - s*q(j,i) + c*q(j,i+1) - q(j,i) = a1 - 50 continue -c - 70 continue -c - end if -c -c %--------------------------% -c | Update the block pointer | -c %--------------------------% -c - istart = iend + 1 -c -c %------------------------------------------% -c | Make sure that h(iend,1) is non-negative | -c | If not then set h(iend,1) <-- -h(iend,1) | -c | and negate the last column of Q. | -c | We have effectively carried out a | -c | similarity on transformation H | -c %------------------------------------------% -c - if (h(iend,1) .lt. zero) then - h(iend,1) = -h(iend,1) - call sscal(kplusp, -one, q(1,iend), 1) - end if -c -c %--------------------------------------------------------% -c | Apply the same shift to the next block if there is any | -c %--------------------------------------------------------% -c - if (iend .lt. kplusp) go to 20 -c -c %-----------------------------------------------------% -c | Check if we can increase the the start of the block | -c %-----------------------------------------------------% -c - do 80 i = itop, kplusp-1 - if (h(i+1,1) .gt. zero) go to 90 - itop = itop + 1 - 80 continue -c -c %-----------------------------------% -c | Finished applying the jj-th shift | -c %-----------------------------------% -c - 90 continue -c -c %------------------------------------------% -c | All shifts have been applied. Check for | -c | more possible deflation that might occur | -c | after the last shift is applied. | -c %------------------------------------------% -c - do 100 i = itop, kplusp-1 - big = abs(h(i,2)) + abs(h(i+1,2)) - if (h(i+1,1) .le. epsmch*big) then - if (msglvl .gt. 0) then - call ivout (logfil, 1, i, ndigit, - & '_sapps: deflation at row/column no.') - call svout (logfil, 1, h(i+1,1), ndigit, - & '_sapps: the corresponding off diagonal element') - end if - h(i+1,1) = zero - end if - 100 continue -c -c %-------------------------------------------------% -c | Compute the (kev+1)-st column of (V*Q) and | -c | temporarily store the result in WORKD(N+1:2*N). | -c | This is not necessary if h(kev+1,1) = 0. | -c %-------------------------------------------------% -c - if ( h(kev+1,1) .gt. zero ) - & call sgemv ('N', n, kplusp, one, v, ldv, - & q(1,kev+1), 1, zero, workd(n+1), 1) -c -c %-------------------------------------------------------% -c | Compute column 1 to kev of (V*Q) in backward order | -c | taking advantage that Q is an upper triangular matrix | -c | with lower bandwidth np. | -c | Place results in v(:,kplusp-kev:kplusp) temporarily. | -c %-------------------------------------------------------% -c - do 130 i = 1, kev - call sgemv ('N', n, kplusp-i+1, one, v, ldv, - & q(1,kev-i+1), 1, zero, workd, 1) - call scopy (n, workd, 1, v(1,kplusp-i+1), 1) - 130 continue -c -c %-------------------------------------------------% -c | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). | -c %-------------------------------------------------% -c - call slacpy ('All', n, kev, v(1,np+1), ldv, v, ldv) -c -c %--------------------------------------------% -c | Copy the (kev+1)-st column of (V*Q) in the | -c | appropriate place if h(kev+1,1) .ne. zero. | -c %--------------------------------------------% -c - if ( h(kev+1,1) .gt. zero ) - & call scopy (n, workd(n+1), 1, v(1,kev+1), 1) -c -c %-------------------------------------% -c | Update the residual vector: | -c | r <- sigmak*r + betak*v(:,kev+1) | -c | where | -c | sigmak = (e_{kev+p}'*Q)*e_{kev} | -c | betak = e_{kev+1}'*H*e_{kev} | -c %-------------------------------------% -c - call sscal (n, q(kplusp,kev), resid, 1) - if (h(kev+1,1) .gt. zero) - & call saxpy (n, h(kev+1,1), v(1,kev+1), 1, resid, 1) -c - if (msglvl .gt. 1) then - call svout (logfil, 1, q(kplusp,kev), ndigit, - & '_sapps: sigmak of the updated residual vector') - call svout (logfil, 1, h(kev+1,1), ndigit, - & '_sapps: betak of the updated residual vector') - call svout (logfil, kev, h(1,2), ndigit, - & '_sapps: updated main diagonal of H for next iteration') - if (kev .gt. 1) then - call svout (logfil, kev-1, h(2,1), ndigit, - & '_sapps: updated sub diagonal of H for next iteration') - end if - end if -c - call arscnd (t1) - tsapps = tsapps + (t1 - t0) -c - 9000 continue - return -c -c %---------------% -c | End of ssapps | -c %---------------% -c - end
--- a/libcruft/arpack/src/ssaup2.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,850 +0,0 @@ -c----------------------------------------------------------------------- -c\BeginDoc -c -c\Name: ssaup2 -c -c\Description: -c Intermediate level interface called by ssaupd. -c -c\Usage: -c call ssaup2 -c ( IDO, BMAT, N, WHICH, NEV, NP, TOL, RESID, MODE, IUPD, -c ISHIFT, MXITER, V, LDV, H, LDH, RITZ, BOUNDS, Q, LDQ, WORKL, -c IPNTR, WORKD, INFO ) -c -c\Arguments -c -c IDO, BMAT, N, WHICH, NEV, TOL, RESID: same as defined in ssaupd. -c MODE, ISHIFT, MXITER: see the definition of IPARAM in ssaupd. -c -c NP Integer. (INPUT/OUTPUT) -c Contains the number of implicit shifts to apply during -c each Arnoldi/Lanczos iteration. -c If ISHIFT=1, NP is adjusted dynamically at each iteration -c to accelerate convergence and prevent stagnation. -c This is also roughly equal to the number of matrix-vector -c products (involving the operator OP) per Arnoldi iteration. -c The logic for adjusting is contained within the current -c subroutine. -c If ISHIFT=0, NP is the number of shifts the user needs -c to provide via reverse comunication. 0 < NP < NCV-NEV. -c NP may be less than NCV-NEV since a leading block of the current -c upper Tridiagonal matrix has split off and contains "unwanted" -c Ritz values. -c Upon termination of the IRA iteration, NP contains the number -c of "converged" wanted Ritz values. -c -c IUPD Integer. (INPUT) -c IUPD .EQ. 0: use explicit restart instead implicit update. -c IUPD .NE. 0: use implicit update. -c -c V Real N by (NEV+NP) array. (INPUT/OUTPUT) -c The Lanczos basis vectors. -c -c LDV Integer. (INPUT) -c Leading dimension of V exactly as declared in the calling -c program. -c -c H Real (NEV+NP) by 2 array. (OUTPUT) -c H is used to store the generated symmetric tridiagonal matrix -c The subdiagonal is stored in the first column of H starting -c at H(2,1). The main diagonal is stored in the second column -c of H starting at H(1,2). If ssaup2 converges store the -c B-norm of the final residual vector in H(1,1). -c -c LDH Integer. (INPUT) -c Leading dimension of H exactly as declared in the calling -c program. -c -c RITZ Real array of length NEV+NP. (OUTPUT) -c RITZ(1:NEV) contains the computed Ritz values of OP. -c -c BOUNDS Real array of length NEV+NP. (OUTPUT) -c BOUNDS(1:NEV) contain the error bounds corresponding to RITZ. -c -c Q Real (NEV+NP) by (NEV+NP) array. (WORKSPACE) -c Private (replicated) work array used to accumulate the -c rotation in the shift application step. -c -c LDQ Integer. (INPUT) -c Leading dimension of Q exactly as declared in the calling -c program. -c -c WORKL Real array of length at least 3*(NEV+NP). (INPUT/WORKSPACE) -c Private (replicated) array on each PE or array allocated on -c the front end. It is used in the computation of the -c tridiagonal eigenvalue problem, the calculation and -c application of the shifts and convergence checking. -c If ISHIFT .EQ. O and IDO .EQ. 3, the first NP locations -c of WORKL are used in reverse communication to hold the user -c supplied shifts. -c -c IPNTR Integer array of length 3. (OUTPUT) -c Pointer to mark the starting locations in the WORKD for -c vectors used by the Lanczos iteration. -c ------------------------------------------------------------- -c IPNTR(1): pointer to the current operand vector X. -c IPNTR(2): pointer to the current result vector Y. -c IPNTR(3): pointer to the vector B * X when used in one of -c the spectral transformation modes. X is the current -c operand. -c ------------------------------------------------------------- -c -c WORKD Real work array of length 3*N. (REVERSE COMMUNICATION) -c Distributed array to be used in the basic Lanczos iteration -c for reverse communication. The user should not use WORKD -c as temporary workspace during the iteration !!!!!!!!!! -c See Data Distribution Note in ssaupd. -c -c INFO Integer. (INPUT/OUTPUT) -c If INFO .EQ. 0, a randomly initial residual vector is used. -c If INFO .NE. 0, RESID contains the initial residual vector, -c possibly from a previous run. -c Error flag on output. -c = 0: Normal return. -c = 1: All possible eigenvalues of OP has been found. -c NP returns the size of the invariant subspace -c spanning the operator OP. -c = 2: No shifts could be applied. -c = -8: Error return from trid. eigenvalue calculation; -c This should never happen. -c = -9: Starting vector is zero. -c = -9999: Could not build an Lanczos factorization. -c Size that was built in returned in NP. -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\References: -c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in -c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), -c pp 357-385. -c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly -c Restarted Arnoldi Iteration", Rice University Technical Report -c TR95-13, Department of Computational and Applied Mathematics. -c 3. B.N. Parlett, "The Symmetric Eigenvalue Problem". Prentice-Hall, -c 1980. -c 4. B.N. Parlett, B. Nour-Omid, "Towards a Black Box Lanczos Program", -c Computer Physics Communications, 53 (1989), pp 169-179. -c 5. B. Nour-Omid, B.N. Parlett, T. Ericson, P.S. Jensen, "How to -c Implement the Spectral Transformation", Math. Comp., 48 (1987), -c pp 663-673. -c 6. R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos -c Algorithm for Solving Sparse Symmetric Generalized Eigenproblems", -c SIAM J. Matr. Anal. Apps., January (1993). -c 7. L. Reichel, W.B. Gragg, "Algorithm 686: FORTRAN Subroutines -c for Updating the QR decomposition", ACM TOMS, December 1990, -c Volume 16 Number 4, pp 369-377. -c -c\Routines called: -c sgetv0 ARPACK initial vector generation routine. -c ssaitr ARPACK Lanczos factorization routine. -c ssapps ARPACK application of implicit shifts routine. -c ssconv ARPACK convergence of Ritz values routine. -c sseigt ARPACK compute Ritz values and error bounds routine. -c ssgets ARPACK reorder Ritz values and error bounds routine. -c ssortr ARPACK sorting routine. -c ivout ARPACK utility routine that prints integers. -c arscnd ARPACK utility routine for timing. -c svout ARPACK utility routine that prints vectors. -c slamch LAPACK routine that determines machine constants. -c scopy Level 1 BLAS that copies one vector to another. -c sdot Level 1 BLAS that computes the scalar product of two vectors. -c snrm2 Level 1 BLAS that computes the norm of a vector. -c sscal Level 1 BLAS that scales a vector. -c sswap Level 1 BLAS that swaps two vectors. -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\Revision history: -c 12/15/93: Version ' 2.4' -c xx/xx/95: Version ' 2.4'. (R.B. Lehoucq) -c -c\SCCS Information: @(#) -c FILE: saup2.F SID: 2.7 DATE OF SID: 5/19/98 RELEASE: 2 -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine ssaup2 - & ( ido, bmat, n, which, nev, np, tol, resid, mode, iupd, - & ishift, mxiter, v, ldv, h, ldh, ritz, bounds, - & q, ldq, workl, ipntr, workd, info ) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - character bmat*1, which*2 - integer ido, info, ishift, iupd, ldh, ldq, ldv, mxiter, - & n, mode, nev, np - Real - & tol -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - integer ipntr(3) - Real - & bounds(nev+np), h(ldh,2), q(ldq,nev+np), resid(n), - & ritz(nev+np), v(ldv,nev+np), workd(3*n), - & workl(3*(nev+np)) -c -c %------------% -c | Parameters | -c %------------% -c - Real - & one, zero - parameter (one = 1.0E+0, zero = 0.0E+0) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - character wprime*2 - logical cnorm, getv0, initv, update, ushift - integer ierr, iter, j, kplusp, msglvl, nconv, nevbef, nev0, - & np0, nptemp, nevd2, nevm2, kp(3) - Real - & rnorm, temp, eps23 - save cnorm, getv0, initv, update, ushift, - & iter, kplusp, msglvl, nconv, nev0, np0, - & rnorm, eps23 -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external scopy, sgetv0, ssaitr, sscal, ssconv, sseigt, ssgets, - & ssapps, ssortr, svout, ivout, arscnd, sswap -c -c %--------------------% -c | External Functions | -c %--------------------% -c - Real - & sdot, snrm2, slamch - external sdot, snrm2, slamch -c -c %---------------------% -c | Intrinsic Functions | -c %---------------------% -c - intrinsic min -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c - if (ido .eq. 0) then -c -c %-------------------------------% -c | Initialize timing statistics | -c | & message level for debugging | -c %-------------------------------% -c - call arscnd (t0) - msglvl = msaup2 -c -c %---------------------------------% -c | Set machine dependent constant. | -c %---------------------------------% -c - eps23 = slamch('Epsilon-Machine') - eps23 = eps23**(2.0E+0/3.0E+0) -c -c %-------------------------------------% -c | nev0 and np0 are integer variables | -c | hold the initial values of NEV & NP | -c %-------------------------------------% -c - nev0 = nev - np0 = np -c -c %-------------------------------------% -c | kplusp is the bound on the largest | -c | Lanczos factorization built. | -c | nconv is the current number of | -c | "converged" eigenvlues. | -c | iter is the counter on the current | -c | iteration step. | -c %-------------------------------------% -c - kplusp = nev0 + np0 - nconv = 0 - iter = 0 -c -c %--------------------------------------------% -c | Set flags for computing the first NEV steps | -c | of the Lanczos factorization. | -c %--------------------------------------------% -c - getv0 = .true. - update = .false. - ushift = .false. - cnorm = .false. -c - if (info .ne. 0) then -c -c %--------------------------------------------% -c | User provides the initial residual vector. | -c %--------------------------------------------% -c - initv = .true. - info = 0 - else - initv = .false. - end if - end if -c -c %---------------------------------------------% -c | Get a possibly random starting vector and | -c | force it into the range of the operator OP. | -c %---------------------------------------------% -c - 10 continue -c - if (getv0) then - call sgetv0 (ido, bmat, 1, initv, n, 1, v, ldv, resid, rnorm, - & ipntr, workd, info) -c - if (ido .ne. 99) go to 9000 -c - if (rnorm .eq. zero) then -c -c %-----------------------------------------% -c | The initial vector is zero. Error exit. | -c %-----------------------------------------% -c - info = -9 - go to 1200 - end if - getv0 = .false. - ido = 0 - end if -c -c %------------------------------------------------------------% -c | Back from reverse communication: continue with update step | -c %------------------------------------------------------------% -c - if (update) go to 20 -c -c %-------------------------------------------% -c | Back from computing user specified shifts | -c %-------------------------------------------% -c - if (ushift) go to 50 -c -c %-------------------------------------% -c | Back from computing residual norm | -c | at the end of the current iteration | -c %-------------------------------------% -c - if (cnorm) go to 100 -c -c %----------------------------------------------------------% -c | Compute the first NEV steps of the Lanczos factorization | -c %----------------------------------------------------------% -c - call ssaitr (ido, bmat, n, 0, nev0, mode, resid, rnorm, v, ldv, - & h, ldh, ipntr, workd, info) -c -c %---------------------------------------------------% -c | ido .ne. 99 implies use of reverse communication | -c | to compute operations involving OP and possibly B | -c %---------------------------------------------------% -c - if (ido .ne. 99) go to 9000 -c - if (info .gt. 0) then -c -c %-----------------------------------------------------% -c | ssaitr was unable to build an Lanczos factorization | -c | of length NEV0. INFO is returned with the size of | -c | the factorization built. Exit main loop. | -c %-----------------------------------------------------% -c - np = info - mxiter = iter - info = -9999 - go to 1200 - end if -c -c %--------------------------------------------------------------% -c | | -c | M A I N LANCZOS I T E R A T I O N L O O P | -c | Each iteration implicitly restarts the Lanczos | -c | factorization in place. | -c | | -c %--------------------------------------------------------------% -c - 1000 continue -c - iter = iter + 1 -c - if (msglvl .gt. 0) then - call ivout (logfil, 1, iter, ndigit, - & '_saup2: **** Start of major iteration number ****') - end if - if (msglvl .gt. 1) then - call ivout (logfil, 1, nev, ndigit, - & '_saup2: The length of the current Lanczos factorization') - call ivout (logfil, 1, np, ndigit, - & '_saup2: Extend the Lanczos factorization by') - end if -c -c %------------------------------------------------------------% -c | Compute NP additional steps of the Lanczos factorization. | -c %------------------------------------------------------------% -c - ido = 0 - 20 continue - update = .true. -c - call ssaitr (ido, bmat, n, nev, np, mode, resid, rnorm, v, - & ldv, h, ldh, ipntr, workd, info) -c -c %---------------------------------------------------% -c | ido .ne. 99 implies use of reverse communication | -c | to compute operations involving OP and possibly B | -c %---------------------------------------------------% -c - if (ido .ne. 99) go to 9000 -c - if (info .gt. 0) then -c -c %-----------------------------------------------------% -c | ssaitr was unable to build an Lanczos factorization | -c | of length NEV0+NP0. INFO is returned with the size | -c | of the factorization built. Exit main loop. | -c %-----------------------------------------------------% -c - np = info - mxiter = iter - info = -9999 - go to 1200 - end if - update = .false. -c - if (msglvl .gt. 1) then - call svout (logfil, 1, rnorm, ndigit, - & '_saup2: Current B-norm of residual for factorization') - end if -c -c %--------------------------------------------------------% -c | Compute the eigenvalues and corresponding error bounds | -c | of the current symmetric tridiagonal matrix. | -c %--------------------------------------------------------% -c - call sseigt (rnorm, kplusp, h, ldh, ritz, bounds, workl, ierr) -c - if (ierr .ne. 0) then - info = -8 - go to 1200 - end if -c -c %----------------------------------------------------% -c | Make a copy of eigenvalues and corresponding error | -c | bounds obtained from _seigt. | -c %----------------------------------------------------% -c - call scopy(kplusp, ritz, 1, workl(kplusp+1), 1) - call scopy(kplusp, bounds, 1, workl(2*kplusp+1), 1) -c -c %---------------------------------------------------% -c | Select the wanted Ritz values and their bounds | -c | to be used in the convergence test. | -c | The selection is based on the requested number of | -c | eigenvalues instead of the current NEV and NP to | -c | prevent possible misconvergence. | -c | * Wanted Ritz values := RITZ(NP+1:NEV+NP) | -c | * Shifts := RITZ(1:NP) := WORKL(1:NP) | -c %---------------------------------------------------% -c - nev = nev0 - np = np0 - call ssgets (ishift, which, nev, np, ritz, bounds, workl) -c -c %-------------------% -c | Convergence test. | -c %-------------------% -c - call scopy (nev, bounds(np+1), 1, workl(np+1), 1) - call ssconv (nev, ritz(np+1), workl(np+1), tol, nconv) -c - if (msglvl .gt. 2) then - kp(1) = nev - kp(2) = np - kp(3) = nconv - call ivout (logfil, 3, kp, ndigit, - & '_saup2: NEV, NP, NCONV are') - call svout (logfil, kplusp, ritz, ndigit, - & '_saup2: The eigenvalues of H') - call svout (logfil, kplusp, bounds, ndigit, - & '_saup2: Ritz estimates of the current NCV Ritz values') - end if -c -c %---------------------------------------------------------% -c | Count the number of unwanted Ritz values that have zero | -c | Ritz estimates. If any Ritz estimates are equal to zero | -c | then a leading block of H of order equal to at least | -c | the number of Ritz values with zero Ritz estimates has | -c | split off. None of these Ritz values may be removed by | -c | shifting. Decrease NP the number of shifts to apply. If | -c | no shifts may be applied, then prepare to exit | -c %---------------------------------------------------------% -c - nptemp = np - do 30 j=1, nptemp - if (bounds(j) .eq. zero) then - np = np - 1 - nev = nev + 1 - end if - 30 continue -c - if ( (nconv .ge. nev0) .or. - & (iter .gt. mxiter) .or. - & (np .eq. 0) ) then -c -c %------------------------------------------------% -c | Prepare to exit. Put the converged Ritz values | -c | and corresponding bounds in RITZ(1:NCONV) and | -c | BOUNDS(1:NCONV) respectively. Then sort. Be | -c | careful when NCONV > NP since we don't want to | -c | swap overlapping locations. | -c %------------------------------------------------% -c - if (which .eq. 'BE') then -c -c %-----------------------------------------------------% -c | Both ends of the spectrum are requested. | -c | Sort the eigenvalues into algebraically decreasing | -c | order first then swap low end of the spectrum next | -c | to high end in appropriate locations. | -c | NOTE: when np < floor(nev/2) be careful not to swap | -c | overlapping locations. | -c %-----------------------------------------------------% -c - wprime = 'SA' - call ssortr (wprime, .true., kplusp, ritz, bounds) - nevd2 = nev0 / 2 - nevm2 = nev0 - nevd2 - if ( nev .gt. 1 ) then - call sswap ( min(nevd2,np), ritz(nevm2+1), 1, - & ritz( max(kplusp-nevd2+1,kplusp-np+1) ), 1) - call sswap ( min(nevd2,np), bounds(nevm2+1), 1, - & bounds( max(kplusp-nevd2+1,kplusp-np+1)), 1) - end if -c - else -c -c %--------------------------------------------------% -c | LM, SM, LA, SA case. | -c | Sort the eigenvalues of H into the an order that | -c | is opposite to WHICH, and apply the resulting | -c | order to BOUNDS. The eigenvalues are sorted so | -c | that the wanted part are always within the first | -c | NEV locations. | -c %--------------------------------------------------% -c - if (which .eq. 'LM') wprime = 'SM' - if (which .eq. 'SM') wprime = 'LM' - if (which .eq. 'LA') wprime = 'SA' - if (which .eq. 'SA') wprime = 'LA' -c - call ssortr (wprime, .true., kplusp, ritz, bounds) -c - end if -c -c %--------------------------------------------------% -c | Scale the Ritz estimate of each Ritz value | -c | by 1 / max(eps23,magnitude of the Ritz value). | -c %--------------------------------------------------% -c - do 35 j = 1, nev0 - temp = max( eps23, abs(ritz(j)) ) - bounds(j) = bounds(j)/temp - 35 continue -c -c %----------------------------------------------------% -c | Sort the Ritz values according to the scaled Ritz | -c | esitmates. This will push all the converged ones | -c | towards the front of ritzr, ritzi, bounds | -c | (in the case when NCONV < NEV.) | -c %----------------------------------------------------% -c - wprime = 'LA' - call ssortr(wprime, .true., nev0, bounds, ritz) -c -c %----------------------------------------------% -c | Scale the Ritz estimate back to its original | -c | value. | -c %----------------------------------------------% -c - do 40 j = 1, nev0 - temp = max( eps23, abs(ritz(j)) ) - bounds(j) = bounds(j)*temp - 40 continue -c -c %--------------------------------------------------% -c | Sort the "converged" Ritz values again so that | -c | the "threshold" values and their associated Ritz | -c | estimates appear at the appropriate position in | -c | ritz and bound. | -c %--------------------------------------------------% -c - if (which .eq. 'BE') then -c -c %------------------------------------------------% -c | Sort the "converged" Ritz values in increasing | -c | order. The "threshold" values are in the | -c | middle. | -c %------------------------------------------------% -c - wprime = 'LA' - call ssortr(wprime, .true., nconv, ritz, bounds) -c - else -c -c %----------------------------------------------% -c | In LM, SM, LA, SA case, sort the "converged" | -c | Ritz values according to WHICH so that the | -c | "threshold" value appears at the front of | -c | ritz. | -c %----------------------------------------------% - - call ssortr(which, .true., nconv, ritz, bounds) -c - end if -c -c %------------------------------------------% -c | Use h( 1,1 ) as storage to communicate | -c | rnorm to _seupd if needed | -c %------------------------------------------% -c - h(1,1) = rnorm -c - if (msglvl .gt. 1) then - call svout (logfil, kplusp, ritz, ndigit, - & '_saup2: Sorted Ritz values.') - call svout (logfil, kplusp, bounds, ndigit, - & '_saup2: Sorted ritz estimates.') - end if -c -c %------------------------------------% -c | Max iterations have been exceeded. | -c %------------------------------------% -c - if (iter .gt. mxiter .and. nconv .lt. nev) info = 1 -c -c %---------------------% -c | No shifts to apply. | -c %---------------------% -c - if (np .eq. 0 .and. nconv .lt. nev0) info = 2 -c - np = nconv - go to 1100 -c - else if (nconv .lt. nev .and. ishift .eq. 1) then -c -c %---------------------------------------------------% -c | Do not have all the requested eigenvalues yet. | -c | To prevent possible stagnation, adjust the number | -c | of Ritz values and the shifts. | -c %---------------------------------------------------% -c - nevbef = nev - nev = nev + min (nconv, np/2) - if (nev .eq. 1 .and. kplusp .ge. 6) then - nev = kplusp / 2 - else if (nev .eq. 1 .and. kplusp .gt. 2) then - nev = 2 - end if - np = kplusp - nev -c -c %---------------------------------------% -c | If the size of NEV was just increased | -c | resort the eigenvalues. | -c %---------------------------------------% -c - if (nevbef .lt. nev) - & call ssgets (ishift, which, nev, np, ritz, bounds, - & workl) -c - end if -c - if (msglvl .gt. 0) then - call ivout (logfil, 1, nconv, ndigit, - & '_saup2: no. of "converged" Ritz values at this iter.') - if (msglvl .gt. 1) then - kp(1) = nev - kp(2) = np - call ivout (logfil, 2, kp, ndigit, - & '_saup2: NEV and NP are') - call svout (logfil, nev, ritz(np+1), ndigit, - & '_saup2: "wanted" Ritz values.') - call svout (logfil, nev, bounds(np+1), ndigit, - & '_saup2: Ritz estimates of the "wanted" values ') - end if - end if - -c - if (ishift .eq. 0) then -c -c %-----------------------------------------------------% -c | User specified shifts: reverse communication to | -c | compute the shifts. They are returned in the first | -c | NP locations of WORKL. | -c %-----------------------------------------------------% -c - ushift = .true. - ido = 3 - go to 9000 - end if -c - 50 continue -c -c %------------------------------------% -c | Back from reverse communication; | -c | User specified shifts are returned | -c | in WORKL(1:*NP) | -c %------------------------------------% -c - ushift = .false. -c -c -c %---------------------------------------------------------% -c | Move the NP shifts to the first NP locations of RITZ to | -c | free up WORKL. This is for the non-exact shift case; | -c | in the exact shift case, ssgets already handles this. | -c %---------------------------------------------------------% -c - if (ishift .eq. 0) call scopy (np, workl, 1, ritz, 1) -c - if (msglvl .gt. 2) then - call ivout (logfil, 1, np, ndigit, - & '_saup2: The number of shifts to apply ') - call svout (logfil, np, workl, ndigit, - & '_saup2: shifts selected') - if (ishift .eq. 1) then - call svout (logfil, np, bounds, ndigit, - & '_saup2: corresponding Ritz estimates') - end if - end if -c -c %---------------------------------------------------------% -c | Apply the NP0 implicit shifts by QR bulge chasing. | -c | Each shift is applied to the entire tridiagonal matrix. | -c | The first 2*N locations of WORKD are used as workspace. | -c | After ssapps is done, we have a Lanczos | -c | factorization of length NEV. | -c %---------------------------------------------------------% -c - call ssapps (n, nev, np, ritz, v, ldv, h, ldh, resid, q, ldq, - & workd) -c -c %---------------------------------------------% -c | Compute the B-norm of the updated residual. | -c | Keep B*RESID in WORKD(1:N) to be used in | -c | the first step of the next call to ssaitr. | -c %---------------------------------------------% -c - cnorm = .true. - call arscnd (t2) - if (bmat .eq. 'G') then - nbx = nbx + 1 - call scopy (n, resid, 1, workd(n+1), 1) - ipntr(1) = n + 1 - ipntr(2) = 1 - ido = 2 -c -c %----------------------------------% -c | Exit in order to compute B*RESID | -c %----------------------------------% -c - go to 9000 - else if (bmat .eq. 'I') then - call scopy (n, resid, 1, workd, 1) - end if -c - 100 continue -c -c %----------------------------------% -c | Back from reverse communication; | -c | WORKD(1:N) := B*RESID | -c %----------------------------------% -c - if (bmat .eq. 'G') then - call arscnd (t3) - tmvbx = tmvbx + (t3 - t2) - end if -c - if (bmat .eq. 'G') then - rnorm = sdot (n, resid, 1, workd, 1) - rnorm = sqrt(abs(rnorm)) - else if (bmat .eq. 'I') then - rnorm = snrm2(n, resid, 1) - end if - cnorm = .false. - 130 continue -c - if (msglvl .gt. 2) then - call svout (logfil, 1, rnorm, ndigit, - & '_saup2: B-norm of residual for NEV factorization') - call svout (logfil, nev, h(1,2), ndigit, - & '_saup2: main diagonal of compressed H matrix') - call svout (logfil, nev-1, h(2,1), ndigit, - & '_saup2: subdiagonal of compressed H matrix') - end if -c - go to 1000 -c -c %---------------------------------------------------------------% -c | | -c | E N D O F M A I N I T E R A T I O N L O O P | -c | | -c %---------------------------------------------------------------% -c - 1100 continue -c - mxiter = iter - nev = nconv -c - 1200 continue - ido = 99 -c -c %------------% -c | Error exit | -c %------------% -c - call arscnd (t1) - tsaup2 = t1 - t0 -c - 9000 continue - return -c -c %---------------% -c | End of ssaup2 | -c %---------------% -c - end
--- a/libcruft/arpack/src/ssaupd.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,690 +0,0 @@ -c----------------------------------------------------------------------- -c\BeginDoc -c -c\Name: ssaupd -c -c\Description: -c -c Reverse communication interface for the Implicitly Restarted Arnoldi -c Iteration. For symmetric problems this reduces to a variant of the Lanczos -c method. This method has been designed to compute approximations to a -c few eigenpairs of a linear operator OP that is real and symmetric -c with respect to a real positive semi-definite symmetric matrix B, -c i.e. -c -c B*OP = (OP`)*B. -c -c Another way to express this condition is -c -c < x,OPy > = < OPx,y > where < z,w > = z`Bw . -c -c In the standard eigenproblem B is the identity matrix. -c ( A` denotes transpose of A) -c -c The computed approximate eigenvalues are called Ritz values and -c the corresponding approximate eigenvectors are called Ritz vectors. -c -c ssaupd is usually called iteratively to solve one of the -c following problems: -c -c Mode 1: A*x = lambda*x, A symmetric -c ===> OP = A and B = I. -c -c Mode 2: A*x = lambda*M*x, A symmetric, M symmetric positive definite -c ===> OP = inv[M]*A and B = M. -c ===> (If M can be factored see remark 3 below) -c -c Mode 3: K*x = lambda*M*x, K symmetric, M symmetric positive semi-definite -c ===> OP = (inv[K - sigma*M])*M and B = M. -c ===> Shift-and-Invert mode -c -c Mode 4: K*x = lambda*KG*x, K symmetric positive semi-definite, -c KG symmetric indefinite -c ===> OP = (inv[K - sigma*KG])*K and B = K. -c ===> Buckling mode -c -c Mode 5: A*x = lambda*M*x, A symmetric, M symmetric positive semi-definite -c ===> OP = inv[A - sigma*M]*[A + sigma*M] and B = M. -c ===> Cayley transformed mode -c -c NOTE: The action of w <- inv[A - sigma*M]*v or w <- inv[M]*v -c should be accomplished either by a direct method -c using a sparse matrix factorization and solving -c -c [A - sigma*M]*w = v or M*w = v, -c -c or through an iterative method for solving these -c systems. If an iterative method is used, the -c convergence test must be more stringent than -c the accuracy requirements for the eigenvalue -c approximations. -c -c\Usage: -c call ssaupd -c ( IDO, BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, -c IPNTR, WORKD, WORKL, LWORKL, INFO ) -c -c\Arguments -c IDO Integer. (INPUT/OUTPUT) -c Reverse communication flag. IDO must be zero on the first -c call to ssaupd. IDO will be set internally to -c indicate the type of operation to be performed. Control is -c then given back to the calling routine which has the -c responsibility to carry out the requested operation and call -c ssaupd with the result. The operand is given in -c WORKD(IPNTR(1)), the result must be put in WORKD(IPNTR(2)). -c (If Mode = 2 see remark 5 below) -c ------------------------------------------------------------- -c IDO = 0: first call to the reverse communication interface -c IDO = -1: compute Y = OP * X where -c IPNTR(1) is the pointer into WORKD for X, -c IPNTR(2) is the pointer into WORKD for Y. -c This is for the initialization phase to force the -c starting vector into the range of OP. -c IDO = 1: compute Y = OP * X where -c IPNTR(1) is the pointer into WORKD for X, -c IPNTR(2) is the pointer into WORKD for Y. -c In mode 3,4 and 5, the vector B * X is already -c available in WORKD(ipntr(3)). It does not -c need to be recomputed in forming OP * X. -c IDO = 2: compute Y = B * X where -c IPNTR(1) is the pointer into WORKD for X, -c IPNTR(2) is the pointer into WORKD for Y. -c IDO = 3: compute the IPARAM(8) shifts where -c IPNTR(11) is the pointer into WORKL for -c placing the shifts. See remark 6 below. -c IDO = 99: done -c ------------------------------------------------------------- -c -c BMAT Character*1. (INPUT) -c BMAT specifies the type of the matrix B that defines the -c semi-inner product for the operator OP. -c B = 'I' -> standard eigenvalue problem A*x = lambda*x -c B = 'G' -> generalized eigenvalue problem A*x = lambda*B*x -c -c N Integer. (INPUT) -c Dimension of the eigenproblem. -c -c WHICH Character*2. (INPUT) -c Specify which of the Ritz values of OP to compute. -c -c 'LA' - compute the NEV largest (algebraic) eigenvalues. -c 'SA' - compute the NEV smallest (algebraic) eigenvalues. -c 'LM' - compute the NEV largest (in magnitude) eigenvalues. -c 'SM' - compute the NEV smallest (in magnitude) eigenvalues. -c 'BE' - compute NEV eigenvalues, half from each end of the -c spectrum. When NEV is odd, compute one more from the -c high end than from the low end. -c (see remark 1 below) -c -c NEV Integer. (INPUT) -c Number of eigenvalues of OP to be computed. 0 < NEV < N. -c -c TOL Real scalar. (INPUT) -c Stopping criterion: the relative accuracy of the Ritz value -c is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I)). -c If TOL .LE. 0. is passed a default is set: -c DEFAULT = SLAMCH('EPS') (machine precision as computed -c by the LAPACK auxiliary subroutine SLAMCH). -c -c RESID Real array of length N. (INPUT/OUTPUT) -c On INPUT: -c If INFO .EQ. 0, a random initial residual vector is used. -c If INFO .NE. 0, RESID contains the initial residual vector, -c possibly from a previous run. -c On OUTPUT: -c RESID contains the final residual vector. -c -c NCV Integer. (INPUT) -c Number of columns of the matrix V (less than or equal to N). -c This will indicate how many Lanczos vectors are generated -c at each iteration. After the startup phase in which NEV -c Lanczos vectors are generated, the algorithm generates -c NCV-NEV Lanczos vectors at each subsequent update iteration. -c Most of the cost in generating each Lanczos vector is in the -c matrix-vector product OP*x. (See remark 4 below). -c -c V Real N by NCV array. (OUTPUT) -c The NCV columns of V contain the Lanczos basis vectors. -c -c LDV Integer. (INPUT) -c Leading dimension of V exactly as declared in the calling -c program. -c -c IPARAM Integer array of length 11. (INPUT/OUTPUT) -c IPARAM(1) = ISHIFT: method for selecting the implicit shifts. -c The shifts selected at each iteration are used to restart -c the Arnoldi iteration in an implicit fashion. -c ------------------------------------------------------------- -c ISHIFT = 0: the shifts are provided by the user via -c reverse communication. The NCV eigenvalues of -c the current tridiagonal matrix T are returned in -c the part of WORKL array corresponding to RITZ. -c See remark 6 below. -c ISHIFT = 1: exact shifts with respect to the reduced -c tridiagonal matrix T. This is equivalent to -c restarting the iteration with a starting vector -c that is a linear combination of Ritz vectors -c associated with the "wanted" Ritz values. -c ------------------------------------------------------------- -c -c IPARAM(2) = LEVEC -c No longer referenced. See remark 2 below. -c -c IPARAM(3) = MXITER -c On INPUT: maximum number of Arnoldi update iterations allowed. -c On OUTPUT: actual number of Arnoldi update iterations taken. -c -c IPARAM(4) = NB: blocksize to be used in the recurrence. -c The code currently works only for NB = 1. -c -c IPARAM(5) = NCONV: number of "converged" Ritz values. -c This represents the number of Ritz values that satisfy -c the convergence criterion. -c -c IPARAM(6) = IUPD -c No longer referenced. Implicit restarting is ALWAYS used. -c -c IPARAM(7) = MODE -c On INPUT determines what type of eigenproblem is being solved. -c Must be 1,2,3,4,5; See under \Description of ssaupd for the -c five modes available. -c -c IPARAM(8) = NP -c When ido = 3 and the user provides shifts through reverse -c communication (IPARAM(1)=0), ssaupd returns NP, the number -c of shifts the user is to provide. 0 < NP <=NCV-NEV. See Remark -c 6 below. -c -c IPARAM(9) = NUMOP, IPARAM(10) = NUMOPB, IPARAM(11) = NUMREO, -c OUTPUT: NUMOP = total number of OP*x operations, -c NUMOPB = total number of B*x operations if BMAT='G', -c NUMREO = total number of steps of re-orthogonalization. -c -c IPNTR Integer array of length 11. (OUTPUT) -c Pointer to mark the starting locations in the WORKD and WORKL -c arrays for matrices/vectors used by the Lanczos iteration. -c ------------------------------------------------------------- -c IPNTR(1): pointer to the current operand vector X in WORKD. -c IPNTR(2): pointer to the current result vector Y in WORKD. -c IPNTR(3): pointer to the vector B * X in WORKD when used in -c the shift-and-invert mode. -c IPNTR(4): pointer to the next available location in WORKL -c that is untouched by the program. -c IPNTR(5): pointer to the NCV by 2 tridiagonal matrix T in WORKL. -c IPNTR(6): pointer to the NCV RITZ values array in WORKL. -c IPNTR(7): pointer to the Ritz estimates in array WORKL associated -c with the Ritz values located in RITZ in WORKL. -c IPNTR(11): pointer to the NP shifts in WORKL. See Remark 6 below. -c -c Note: IPNTR(8:10) is only referenced by sseupd. See Remark 2. -c IPNTR(8): pointer to the NCV RITZ values of the original system. -c IPNTR(9): pointer to the NCV corresponding error bounds. -c IPNTR(10): pointer to the NCV by NCV matrix of eigenvectors -c of the tridiagonal matrix T. Only referenced by -c sseupd if RVEC = .TRUE. See Remarks. -c ------------------------------------------------------------- -c -c WORKD Real work array of length 3*N. (REVERSE COMMUNICATION) -c Distributed array to be used in the basic Arnoldi iteration -c for reverse communication. The user should not use WORKD -c as temporary workspace during the iteration. Upon termination -c WORKD(1:N) contains B*RESID(1:N). If the Ritz vectors are desired -c subroutine sseupd uses this output. -c See Data Distribution Note below. -c -c WORKL Real work array of length LWORKL. (OUTPUT/WORKSPACE) -c Private (replicated) array on each PE or array allocated on -c the front end. See Data Distribution Note below. -c -c LWORKL Integer. (INPUT) -c LWORKL must be at least NCV**2 + 8*NCV . -c -c INFO Integer. (INPUT/OUTPUT) -c If INFO .EQ. 0, a randomly initial residual vector is used. -c If INFO .NE. 0, RESID contains the initial residual vector, -c possibly from a previous run. -c Error flag on output. -c = 0: Normal exit. -c = 1: Maximum number of iterations taken. -c All possible eigenvalues of OP has been found. IPARAM(5) -c returns the number of wanted converged Ritz values. -c = 2: No longer an informational error. Deprecated starting -c with release 2 of ARPACK. -c = 3: No shifts could be applied during a cycle of the -c Implicitly restarted Arnoldi iteration. One possibility -c is to increase the size of NCV relative to NEV. -c See remark 4 below. -c = -1: N must be positive. -c = -2: NEV must be positive. -c = -3: NCV must be greater than NEV and less than or equal to N. -c = -4: The maximum number of Arnoldi update iterations allowed -c must be greater than zero. -c = -5: WHICH must be one of 'LM', 'SM', 'LA', 'SA' or 'BE'. -c = -6: BMAT must be one of 'I' or 'G'. -c = -7: Length of private work array WORKL is not sufficient. -c = -8: Error return from trid. eigenvalue calculation; -c Informatinal error from LAPACK routine ssteqr. -c = -9: Starting vector is zero. -c = -10: IPARAM(7) must be 1,2,3,4,5. -c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatable. -c = -12: IPARAM(1) must be equal to 0 or 1. -c = -13: NEV and WHICH = 'BE' are incompatable. -c = -9999: Could not build an Arnoldi factorization. -c IPARAM(5) returns the size of the current Arnoldi -c factorization. The user is advised to check that -c enough workspace and array storage has been allocated. -c -c -c\Remarks -c 1. The converged Ritz values are always returned in ascending -c algebraic order. The computed Ritz values are approximate -c eigenvalues of OP. The selection of WHICH should be made -c with this in mind when Mode = 3,4,5. After convergence, -c approximate eigenvalues of the original problem may be obtained -c with the ARPACK subroutine sseupd. -c -c 2. If the Ritz vectors corresponding to the converged Ritz values -c are needed, the user must call sseupd immediately following completion -c of ssaupd. This is new starting with version 2.1 of ARPACK. -c -c 3. If M can be factored into a Cholesky factorization M = LL` -c then Mode = 2 should not be selected. Instead one should use -c Mode = 1 with OP = inv(L)*A*inv(L`). Appropriate triangular -c linear systems should be solved with L and L` rather -c than computing inverses. After convergence, an approximate -c eigenvector z of the original problem is recovered by solving -c L`z = x where x is a Ritz vector of OP. -c -c 4. At present there is no a-priori analysis to guide the selection -c of NCV relative to NEV. The only formal requrement is that NCV > NEV. -c However, it is recommended that NCV .ge. 2*NEV. If many problems of -c the same type are to be solved, one should experiment with increasing -c NCV while keeping NEV fixed for a given test problem. This will -c usually decrease the required number of OP*x operations but it -c also increases the work and storage required to maintain the orthogonal -c basis vectors. The optimal "cross-over" with respect to CPU time -c is problem dependent and must be determined empirically. -c -c 5. If IPARAM(7) = 2 then in the Reverse commuication interface the user -c must do the following. When IDO = 1, Y = OP * X is to be computed. -c When IPARAM(7) = 2 OP = inv(B)*A. After computing A*X the user -c must overwrite X with A*X. Y is then the solution to the linear set -c of equations B*Y = A*X. -c -c 6. When IPARAM(1) = 0, and IDO = 3, the user needs to provide the -c NP = IPARAM(8) shifts in locations: -c 1 WORKL(IPNTR(11)) -c 2 WORKL(IPNTR(11)+1) -c . -c . -c . -c NP WORKL(IPNTR(11)+NP-1). -c -c The eigenvalues of the current tridiagonal matrix are located in -c WORKL(IPNTR(6)) through WORKL(IPNTR(6)+NCV-1). They are in the -c order defined by WHICH. The associated Ritz estimates are located in -c WORKL(IPNTR(8)), WORKL(IPNTR(8)+1), ... , WORKL(IPNTR(8)+NCV-1). -c -c----------------------------------------------------------------------- -c -c\Data Distribution Note: -c -c Fortran-D syntax: -c ================ -c REAL RESID(N), V(LDV,NCV), WORKD(3*N), WORKL(LWORKL) -c DECOMPOSE D1(N), D2(N,NCV) -c ALIGN RESID(I) with D1(I) -c ALIGN V(I,J) with D2(I,J) -c ALIGN WORKD(I) with D1(I) range (1:N) -c ALIGN WORKD(I) with D1(I-N) range (N+1:2*N) -c ALIGN WORKD(I) with D1(I-2*N) range (2*N+1:3*N) -c DISTRIBUTE D1(BLOCK), D2(BLOCK,:) -c REPLICATED WORKL(LWORKL) -c -c Cray MPP syntax: -c =============== -c REAL RESID(N), V(LDV,NCV), WORKD(N,3), WORKL(LWORKL) -c SHARED RESID(BLOCK), V(BLOCK,:), WORKD(BLOCK,:) -c REPLICATED WORKL(LWORKL) -c -c -c\BeginLib -c -c\References: -c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in -c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), -c pp 357-385. -c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly -c Restarted Arnoldi Iteration", Rice University Technical Report -c TR95-13, Department of Computational and Applied Mathematics. -c 3. B.N. Parlett, "The Symmetric Eigenvalue Problem". Prentice-Hall, -c 1980. -c 4. B.N. Parlett, B. Nour-Omid, "Towards a Black Box Lanczos Program", -c Computer Physics Communications, 53 (1989), pp 169-179. -c 5. B. Nour-Omid, B.N. Parlett, T. Ericson, P.S. Jensen, "How to -c Implement the Spectral Transformation", Math. Comp., 48 (1987), -c pp 663-673. -c 6. R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos -c Algorithm for Solving Sparse Symmetric Generalized Eigenproblems", -c SIAM J. Matr. Anal. Apps., January (1993). -c 7. L. Reichel, W.B. Gragg, "Algorithm 686: FORTRAN Subroutines -c for Updating the QR decomposition", ACM TOMS, December 1990, -c Volume 16 Number 4, pp 369-377. -c 8. R.B. Lehoucq, D.C. Sorensen, "Implementation of Some Spectral -c Transformations in a k-Step Arnoldi Method". In Preparation. -c -c\Routines called: -c ssaup2 ARPACK routine that implements the Implicitly Restarted -c Arnoldi Iteration. -c sstats ARPACK routine that initialize timing and other statistics -c variables. -c ivout ARPACK utility routine that prints integers. -c arscnd ARPACK utility routine for timing. -c svout ARPACK utility routine that prints vectors. -c slamch LAPACK routine that determines machine constants. -c -c\Authors -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\Revision history: -c 12/15/93: Version ' 2.4' -c -c\SCCS Information: @(#) -c FILE: saupd.F SID: 2.8 DATE OF SID: 04/10/01 RELEASE: 2 -c -c\Remarks -c 1. None -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine ssaupd - & ( ido, bmat, n, which, nev, tol, resid, ncv, v, ldv, iparam, - & ipntr, workd, workl, lworkl, info ) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - character bmat*1, which*2 - integer ido, info, ldv, lworkl, n, ncv, nev - Real - & tol -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - integer iparam(11), ipntr(11) - Real - & resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) -c -c %------------% -c | Parameters | -c %------------% -c - Real - & one, zero - parameter (one = 1.0E+0 , zero = 0.0E+0 ) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - integer bounds, ierr, ih, iq, ishift, iupd, iw, - & ldh, ldq, msglvl, mxiter, mode, nb, - & nev0, next, np, ritz, j - save bounds, ierr, ih, iq, ishift, iupd, iw, - & ldh, ldq, msglvl, mxiter, mode, nb, - & nev0, next, np, ritz -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external ssaup2, svout, ivout, arscnd, sstats -c -c %--------------------% -c | External Functions | -c %--------------------% -c - Real - & slamch - external slamch -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c - if (ido .eq. 0) then -c -c %-------------------------------% -c | Initialize timing statistics | -c | & message level for debugging | -c %-------------------------------% -c - call sstats - call arscnd (t0) - msglvl = msaupd -c - ierr = 0 - ishift = iparam(1) - mxiter = iparam(3) -c nb = iparam(4) - nb = 1 -c -c %--------------------------------------------% -c | Revision 2 performs only implicit restart. | -c %--------------------------------------------% -c - iupd = 1 - mode = iparam(7) -c -c %----------------% -c | Error checking | -c %----------------% -c - if (n .le. 0) then - ierr = -1 - else if (nev .le. 0) then - ierr = -2 - else if (ncv .le. nev .or. ncv .gt. n) then - ierr = -3 - end if -c -c %----------------------------------------------% -c | NP is the number of additional steps to | -c | extend the length NEV Lanczos factorization. | -c %----------------------------------------------% -c - np = ncv - nev -c - if (mxiter .le. 0) ierr = -4 - if (which .ne. 'LM' .and. - & which .ne. 'SM' .and. - & which .ne. 'LA' .and. - & which .ne. 'SA' .and. - & which .ne. 'BE') ierr = -5 - if (bmat .ne. 'I' .and. bmat .ne. 'G') ierr = -6 -c - if (lworkl .lt. ncv**2 + 8*ncv) ierr = -7 - if (mode .lt. 1 .or. mode .gt. 5) then - ierr = -10 - else if (mode .eq. 1 .and. bmat .eq. 'G') then - ierr = -11 - else if (ishift .lt. 0 .or. ishift .gt. 1) then - ierr = -12 - else if (nev .eq. 1 .and. which .eq. 'BE') then - ierr = -13 - end if -c -c %------------% -c | Error Exit | -c %------------% -c - if (ierr .ne. 0) then - info = ierr - ido = 99 - go to 9000 - end if -c -c %------------------------% -c | Set default parameters | -c %------------------------% -c - if (nb .le. 0) nb = 1 - if (tol .le. zero) tol = slamch('EpsMach') -c -c %----------------------------------------------% -c | NP is the number of additional steps to | -c | extend the length NEV Lanczos factorization. | -c | NEV0 is the local variable designating the | -c | size of the invariant subspace desired. | -c %----------------------------------------------% -c - np = ncv - nev - nev0 = nev -c -c %-----------------------------% -c | Zero out internal workspace | -c %-----------------------------% -c - do 10 j = 1, ncv**2 + 8*ncv - workl(j) = zero - 10 continue -c -c %-------------------------------------------------------% -c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | -c | etc... and the remaining workspace. | -c | Also update pointer to be used on output. | -c | Memory is laid out as follows: | -c | workl(1:2*ncv) := generated tridiagonal matrix | -c | workl(2*ncv+1:2*ncv+ncv) := ritz values | -c | workl(3*ncv+1:3*ncv+ncv) := computed error bounds | -c | workl(4*ncv+1:4*ncv+ncv*ncv) := rotation matrix Q | -c | workl(4*ncv+ncv*ncv+1:7*ncv+ncv*ncv) := workspace | -c %-------------------------------------------------------% -c - ldh = ncv - ldq = ncv - ih = 1 - ritz = ih + 2*ldh - bounds = ritz + ncv - iq = bounds + ncv - iw = iq + ncv**2 - next = iw + 3*ncv -c - ipntr(4) = next - ipntr(5) = ih - ipntr(6) = ritz - ipntr(7) = bounds - ipntr(11) = iw - end if -c -c %-------------------------------------------------------% -c | Carry out the Implicitly restarted Lanczos Iteration. | -c %-------------------------------------------------------% -c - call ssaup2 - & ( ido, bmat, n, which, nev0, np, tol, resid, mode, iupd, - & ishift, mxiter, v, ldv, workl(ih), ldh, workl(ritz), - & workl(bounds), workl(iq), ldq, workl(iw), ipntr, workd, - & info ) -c -c %--------------------------------------------------% -c | ido .ne. 99 implies use of reverse communication | -c | to compute operations involving OP or shifts. | -c %--------------------------------------------------% -c - if (ido .eq. 3) iparam(8) = np - if (ido .ne. 99) go to 9000 -c - iparam(3) = mxiter - iparam(5) = np - iparam(9) = nopx - iparam(10) = nbx - iparam(11) = nrorth -c -c %------------------------------------% -c | Exit if there was an informational | -c | error within ssaup2. | -c %------------------------------------% -c - if (info .lt. 0) go to 9000 - if (info .eq. 2) info = 3 -c - if (msglvl .gt. 0) then - call ivout (logfil, 1, mxiter, ndigit, - & '_saupd: number of update iterations taken') - call ivout (logfil, 1, np, ndigit, - & '_saupd: number of "converged" Ritz values') - call svout (logfil, np, workl(Ritz), ndigit, - & '_saupd: final Ritz values') - call svout (logfil, np, workl(Bounds), ndigit, - & '_saupd: corresponding error bounds') - end if -c - call arscnd (t1) - tsaupd = t1 - t0 -c - if (msglvl .gt. 0) then -c -c %--------------------------------------------------------% -c | Version Number & Version Date are defined in version.h | -c %--------------------------------------------------------% -c - write (6,1000) - write (6,1100) mxiter, nopx, nbx, nrorth, nitref, nrstrt, - & tmvopx, tmvbx, tsaupd, tsaup2, tsaitr, titref, - & tgetv0, tseigt, tsgets, tsapps, tsconv - 1000 format (//, - & 5x, '==========================================',/ - & 5x, '= Symmetric implicit Arnoldi update code =',/ - & 5x, '= Version Number:', ' 2.4' , 19x, ' =',/ - & 5x, '= Version Date: ', ' 07/31/96' , 14x, ' =',/ - & 5x, '==========================================',/ - & 5x, '= Summary of timing statistics =',/ - & 5x, '==========================================',//) - 1100 format ( - & 5x, 'Total number update iterations = ', i5,/ - & 5x, 'Total number of OP*x operations = ', i5,/ - & 5x, 'Total number of B*x operations = ', i5,/ - & 5x, 'Total number of reorthogonalization steps = ', i5,/ - & 5x, 'Total number of iterative refinement steps = ', i5,/ - & 5x, 'Total number of restart steps = ', i5,/ - & 5x, 'Total time in user OP*x operation = ', f12.6,/ - & 5x, 'Total time in user B*x operation = ', f12.6,/ - & 5x, 'Total time in Arnoldi update routine = ', f12.6,/ - & 5x, 'Total time in saup2 routine = ', f12.6,/ - & 5x, 'Total time in basic Arnoldi iteration loop = ', f12.6,/ - & 5x, 'Total time in reorthogonalization phase = ', f12.6,/ - & 5x, 'Total time in (re)start vector generation = ', f12.6,/ - & 5x, 'Total time in trid eigenvalue subproblem = ', f12.6,/ - & 5x, 'Total time in getting the shifts = ', f12.6,/ - & 5x, 'Total time in applying the shifts = ', f12.6,/ - & 5x, 'Total time in convergence testing = ', f12.6) - end if -c - 9000 continue -c - return -c -c %---------------% -c | End of ssaupd | -c %---------------% -c - end
--- a/libcruft/arpack/src/ssconv.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,138 +0,0 @@ -c----------------------------------------------------------------------- -c\BeginDoc -c -c\Name: ssconv -c -c\Description: -c Convergence testing for the symmetric Arnoldi eigenvalue routine. -c -c\Usage: -c call ssconv -c ( N, RITZ, BOUNDS, TOL, NCONV ) -c -c\Arguments -c N Integer. (INPUT) -c Number of Ritz values to check for convergence. -c -c RITZ Real array of length N. (INPUT) -c The Ritz values to be checked for convergence. -c -c BOUNDS Real array of length N. (INPUT) -c Ritz estimates associated with the Ritz values in RITZ. -c -c TOL Real scalar. (INPUT) -c Desired relative accuracy for a Ritz value to be considered -c "converged". -c -c NCONV Integer scalar. (OUTPUT) -c Number of "converged" Ritz values. -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Routines called: -c arscnd ARPACK utility routine for timing. -c slamch LAPACK routine that determines machine constants. -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\SCCS Information: @(#) -c FILE: sconv.F SID: 2.4 DATE OF SID: 4/19/96 RELEASE: 2 -c -c\Remarks -c 1. Starting with version 2.4, this routine no longer uses the -c Parlett strategy using the gap conditions. -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine ssconv (n, ritz, bounds, tol, nconv) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - integer n, nconv - Real - & tol -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - Real - & ritz(n), bounds(n) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - integer i - Real - & temp, eps23 -c -c %-------------------% -c | External routines | -c %-------------------% -c - Real - & slamch - external slamch - -c %---------------------% -c | Intrinsic Functions | -c %---------------------% -c - intrinsic abs -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c - call arscnd (t0) -c - eps23 = slamch('Epsilon-Machine') - eps23 = eps23**(2.0E+0 / 3.0E+0) -c - nconv = 0 - do 10 i = 1, n -c -c %-----------------------------------------------------% -c | The i-th Ritz value is considered "converged" | -c | when: bounds(i) .le. TOL*max(eps23, abs(ritz(i))) | -c %-----------------------------------------------------% -c - temp = max( eps23, abs(ritz(i)) ) - if ( bounds(i) .le. tol*temp ) then - nconv = nconv + 1 - end if -c - 10 continue -c - call arscnd (t1) - tsconv = tsconv + (t1 - t0) -c - return -c -c %---------------% -c | End of ssconv | -c %---------------% -c - end
--- a/libcruft/arpack/src/sseigt.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,181 +0,0 @@ -c----------------------------------------------------------------------- -c\BeginDoc -c -c\Name: sseigt -c -c\Description: -c Compute the eigenvalues of the current symmetric tridiagonal matrix -c and the corresponding error bounds given the current residual norm. -c -c\Usage: -c call sseigt -c ( RNORM, N, H, LDH, EIG, BOUNDS, WORKL, IERR ) -c -c\Arguments -c RNORM Real scalar. (INPUT) -c RNORM contains the residual norm corresponding to the current -c symmetric tridiagonal matrix H. -c -c N Integer. (INPUT) -c Size of the symmetric tridiagonal matrix H. -c -c H Real N by 2 array. (INPUT) -c H contains the symmetric tridiagonal matrix with the -c subdiagonal in the first column starting at H(2,1) and the -c main diagonal in second column. -c -c LDH Integer. (INPUT) -c Leading dimension of H exactly as declared in the calling -c program. -c -c EIG Real array of length N. (OUTPUT) -c On output, EIG contains the N eigenvalues of H possibly -c unsorted. The BOUNDS arrays are returned in the -c same sorted order as EIG. -c -c BOUNDS Real array of length N. (OUTPUT) -c On output, BOUNDS contains the error estimates corresponding -c to the eigenvalues EIG. This is equal to RNORM times the -c last components of the eigenvectors corresponding to the -c eigenvalues in EIG. -c -c WORKL Real work array of length 3*N. (WORKSPACE) -c Private (replicated) array on each PE or array allocated on -c the front end. -c -c IERR Integer. (OUTPUT) -c Error exit flag from sstqrb. -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Local variables: -c xxxxxx real -c -c\Routines called: -c sstqrb ARPACK routine that computes the eigenvalues and the -c last components of the eigenvectors of a symmetric -c and tridiagonal matrix. -c arscnd ARPACK utility routine for timing. -c svout ARPACK utility routine that prints vectors. -c scopy Level 1 BLAS that copies one vector to another. -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\Revision history: -c xx/xx/92: Version ' 2.4' -c -c\SCCS Information: @(#) -c FILE: seigt.F SID: 2.4 DATE OF SID: 8/27/96 RELEASE: 2 -c -c\Remarks -c None -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine sseigt - & ( rnorm, n, h, ldh, eig, bounds, workl, ierr ) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - integer ierr, ldh, n - Real - & rnorm -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - Real - & eig(n), bounds(n), h(ldh,2), workl(3*n) -c -c %------------% -c | Parameters | -c %------------% -c - Real - & zero - parameter (zero = 0.0E+0) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - integer i, k, msglvl -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external scopy, sstqrb, svout, arscnd -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c -c %-------------------------------% -c | Initialize timing statistics | -c | & message level for debugging | -c %-------------------------------% -c - call arscnd (t0) - msglvl = mseigt -c - if (msglvl .gt. 0) then - call svout (logfil, n, h(1,2), ndigit, - & '_seigt: main diagonal of matrix H') - if (n .gt. 1) then - call svout (logfil, n-1, h(2,1), ndigit, - & '_seigt: sub diagonal of matrix H') - end if - end if -c - call scopy (n, h(1,2), 1, eig, 1) - call scopy (n-1, h(2,1), 1, workl, 1) - call sstqrb (n, eig, workl, bounds, workl(n+1), ierr) - if (ierr .ne. 0) go to 9000 - if (msglvl .gt. 1) then - call svout (logfil, n, bounds, ndigit, - & '_seigt: last row of the eigenvector matrix for H') - end if -c -c %-----------------------------------------------% -c | Finally determine the error bounds associated | -c | with the n Ritz values of H. | -c %-----------------------------------------------% -c - do 30 k = 1, n - bounds(k) = rnorm*abs(bounds(k)) - 30 continue -c - call arscnd (t1) - tseigt = tseigt + (t1 - t0) -c - 9000 continue - return -c -c %---------------% -c | End of sseigt | -c %---------------% -c - end
--- a/libcruft/arpack/src/ssesrt.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,217 +0,0 @@ -c----------------------------------------------------------------------- -c\BeginDoc -c -c\Name: ssesrt -c -c\Description: -c Sort the array X in the order specified by WHICH and optionally -c apply the permutation to the columns of the matrix A. -c -c\Usage: -c call ssesrt -c ( WHICH, APPLY, N, X, NA, A, LDA) -c -c\Arguments -c WHICH Character*2. (Input) -c 'LM' -> X is sorted into increasing order of magnitude. -c 'SM' -> X is sorted into decreasing order of magnitude. -c 'LA' -> X is sorted into increasing order of algebraic. -c 'SA' -> X is sorted into decreasing order of algebraic. -c -c APPLY Logical. (Input) -c APPLY = .TRUE. -> apply the sorted order to A. -c APPLY = .FALSE. -> do not apply the sorted order to A. -c -c N Integer. (INPUT) -c Dimension of the array X. -c -c X Real array of length N. (INPUT/OUTPUT) -c The array to be sorted. -c -c NA Integer. (INPUT) -c Number of rows of the matrix A. -c -c A Real array of length NA by N. (INPUT/OUTPUT) -c -c LDA Integer. (INPUT) -c Leading dimension of A. -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Routines -c sswap Level 1 BLAS that swaps the contents of two vectors. -c -c\Authors -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\Revision history: -c 12/15/93: Version ' 2.1'. -c Adapted from the sort routine in LANSO and -c the ARPACK code ssortr -c -c\SCCS Information: @(#) -c FILE: sesrt.F SID: 2.3 DATE OF SID: 4/19/96 RELEASE: 2 -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine ssesrt (which, apply, n, x, na, a, lda) -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - character*2 which - logical apply - integer lda, n, na -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - Real - & x(0:n-1), a(lda, 0:n-1) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - integer i, igap, j - Real - & temp -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external sswap -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c - igap = n / 2 -c - if (which .eq. 'SA') then -c -c X is sorted into decreasing order of algebraic. -c - 10 continue - if (igap .eq. 0) go to 9000 - do 30 i = igap, n-1 - j = i-igap - 20 continue -c - if (j.lt.0) go to 30 -c - if (x(j).lt.x(j+igap)) then - temp = x(j) - x(j) = x(j+igap) - x(j+igap) = temp - if (apply) call sswap( na, a(1, j), 1, a(1,j+igap), 1) - else - go to 30 - endif - j = j-igap - go to 20 - 30 continue - igap = igap / 2 - go to 10 -c - else if (which .eq. 'SM') then -c -c X is sorted into decreasing order of magnitude. -c - 40 continue - if (igap .eq. 0) go to 9000 - do 60 i = igap, n-1 - j = i-igap - 50 continue -c - if (j.lt.0) go to 60 -c - if (abs(x(j)).lt.abs(x(j+igap))) then - temp = x(j) - x(j) = x(j+igap) - x(j+igap) = temp - if (apply) call sswap( na, a(1, j), 1, a(1,j+igap), 1) - else - go to 60 - endif - j = j-igap - go to 50 - 60 continue - igap = igap / 2 - go to 40 -c - else if (which .eq. 'LA') then -c -c X is sorted into increasing order of algebraic. -c - 70 continue - if (igap .eq. 0) go to 9000 - do 90 i = igap, n-1 - j = i-igap - 80 continue -c - if (j.lt.0) go to 90 -c - if (x(j).gt.x(j+igap)) then - temp = x(j) - x(j) = x(j+igap) - x(j+igap) = temp - if (apply) call sswap( na, a(1, j), 1, a(1,j+igap), 1) - else - go to 90 - endif - j = j-igap - go to 80 - 90 continue - igap = igap / 2 - go to 70 -c - else if (which .eq. 'LM') then -c -c X is sorted into increasing order of magnitude. -c - 100 continue - if (igap .eq. 0) go to 9000 - do 120 i = igap, n-1 - j = i-igap - 110 continue -c - if (j.lt.0) go to 120 -c - if (abs(x(j)).gt.abs(x(j+igap))) then - temp = x(j) - x(j) = x(j+igap) - x(j+igap) = temp - if (apply) call sswap( na, a(1, j), 1, a(1,j+igap), 1) - else - go to 120 - endif - j = j-igap - go to 110 - 120 continue - igap = igap / 2 - go to 100 - end if -c - 9000 continue - return -c -c %---------------% -c | End of ssesrt | -c %---------------% -c - end
--- a/libcruft/arpack/src/sseupd.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,857 +0,0 @@ -c\BeginDoc -c -c\Name: sseupd -c -c\Description: -c -c This subroutine returns the converged approximations to eigenvalues -c of A*z = lambda*B*z and (optionally): -c -c (1) the corresponding approximate eigenvectors, -c -c (2) an orthonormal (Lanczos) basis for the associated approximate -c invariant subspace, -c -c (3) Both. -c -c There is negligible additional cost to obtain eigenvectors. An orthonormal -c (Lanczos) basis is always computed. There is an additional storage cost -c of n*nev if both are requested (in this case a separate array Z must be -c supplied). -c -c These quantities are obtained from the Lanczos factorization computed -c by SSAUPD for the linear operator OP prescribed by the MODE selection -c (see IPARAM(7) in SSAUPD documentation.) SSAUPD must be called before -c this routine is called. These approximate eigenvalues and vectors are -c commonly called Ritz values and Ritz vectors respectively. They are -c referred to as such in the comments that follow. The computed orthonormal -c basis for the invariant subspace corresponding to these Ritz values is -c referred to as a Lanczos basis. -c -c See documentation in the header of the subroutine SSAUPD for a definition -c of OP as well as other terms and the relation of computed Ritz values -c and vectors of OP with respect to the given problem A*z = lambda*B*z. -c -c The approximate eigenvalues of the original problem are returned in -c ascending algebraic order. The user may elect to call this routine -c once for each desired Ritz vector and store it peripherally if desired. -c There is also the option of computing a selected set of these vectors -c with a single call. -c -c\Usage: -c call sseupd -c ( RVEC, HOWMNY, SELECT, D, Z, LDZ, SIGMA, BMAT, N, WHICH, NEV, TOL, -c RESID, NCV, V, LDV, IPARAM, IPNTR, WORKD, WORKL, LWORKL, INFO ) -c -c RVEC LOGICAL (INPUT) -c Specifies whether Ritz vectors corresponding to the Ritz value -c approximations to the eigenproblem A*z = lambda*B*z are computed. -c -c RVEC = .FALSE. Compute Ritz values only. -c -c RVEC = .TRUE. Compute Ritz vectors. -c -c HOWMNY Character*1 (INPUT) -c Specifies how many Ritz vectors are wanted and the form of Z -c the matrix of Ritz vectors. See remark 1 below. -c = 'A': compute NEV Ritz vectors; -c = 'S': compute some of the Ritz vectors, specified -c by the logical array SELECT. -c -c SELECT Logical array of dimension NCV. (INPUT/WORKSPACE) -c If HOWMNY = 'S', SELECT specifies the Ritz vectors to be -c computed. To select the Ritz vector corresponding to a -c Ritz value D(j), SELECT(j) must be set to .TRUE.. -c If HOWMNY = 'A' , SELECT is used as a workspace for -c reordering the Ritz values. -c -c D Real array of dimension NEV. (OUTPUT) -c On exit, D contains the Ritz value approximations to the -c eigenvalues of A*z = lambda*B*z. The values are returned -c in ascending order. If IPARAM(7) = 3,4,5 then D represents -c the Ritz values of OP computed by ssaupd transformed to -c those of the original eigensystem A*z = lambda*B*z. If -c IPARAM(7) = 1,2 then the Ritz values of OP are the same -c as the those of A*z = lambda*B*z. -c -c Z Real N by NEV array if HOWMNY = 'A'. (OUTPUT) -c On exit, Z contains the B-orthonormal Ritz vectors of the -c eigensystem A*z = lambda*B*z corresponding to the Ritz -c value approximations. -c If RVEC = .FALSE. then Z is not referenced. -c NOTE: The array Z may be set equal to first NEV columns of the -c Arnoldi/Lanczos basis array V computed by SSAUPD. -c -c LDZ Integer. (INPUT) -c The leading dimension of the array Z. If Ritz vectors are -c desired, then LDZ .ge. max( 1, N ). In any case, LDZ .ge. 1. -c -c SIGMA Real (INPUT) -c If IPARAM(7) = 3,4,5 represents the shift. Not referenced if -c IPARAM(7) = 1 or 2. -c -c -c **** The remaining arguments MUST be the same as for the **** -c **** call to SSAUPD that was just completed. **** -c -c NOTE: The remaining arguments -c -c BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, -c WORKD, WORKL, LWORKL, INFO -c -c must be passed directly to SSEUPD following the last call -c to SSAUPD. These arguments MUST NOT BE MODIFIED between -c the the last call to SSAUPD and the call to SSEUPD. -c -c Two of these parameters (WORKL, INFO) are also output parameters: -c -c WORKL Real work array of length LWORKL. (OUTPUT/WORKSPACE) -c WORKL(1:4*ncv) contains information obtained in -c ssaupd. They are not changed by sseupd. -c WORKL(4*ncv+1:ncv*ncv+8*ncv) holds the -c untransformed Ritz values, the computed error estimates, -c and the associated eigenvector matrix of H. -c -c Note: IPNTR(8:10) contains the pointer into WORKL for addresses -c of the above information computed by sseupd. -c ------------------------------------------------------------- -c IPNTR(8): pointer to the NCV RITZ values of the original system. -c IPNTR(9): pointer to the NCV corresponding error bounds. -c IPNTR(10): pointer to the NCV by NCV matrix of eigenvectors -c of the tridiagonal matrix T. Only referenced by -c sseupd if RVEC = .TRUE. See Remarks. -c ------------------------------------------------------------- -c -c INFO Integer. (OUTPUT) -c Error flag on output. -c = 0: Normal exit. -c = -1: N must be positive. -c = -2: NEV must be positive. -c = -3: NCV must be greater than NEV and less than or equal to N. -c = -5: WHICH must be one of 'LM', 'SM', 'LA', 'SA' or 'BE'. -c = -6: BMAT must be one of 'I' or 'G'. -c = -7: Length of private work WORKL array is not sufficient. -c = -8: Error return from trid. eigenvalue calculation; -c Information error from LAPACK routine ssteqr. -c = -9: Starting vector is zero. -c = -10: IPARAM(7) must be 1,2,3,4,5. -c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. -c = -12: NEV and WHICH = 'BE' are incompatible. -c = -14: SSAUPD did not find any eigenvalues to sufficient -c accuracy. -c = -15: HOWMNY must be one of 'A' or 'S' if RVEC = .true. -c = -16: HOWMNY = 'S' not yet implemented -c = -17: SSEUPD got a different count of the number of converged -c Ritz values than SSAUPD got. This indicates the user -c probably made an error in passing data from SSAUPD to -c SSEUPD or that the data was modified before entering -c SSEUPD. -c -c\BeginLib -c -c\References: -c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in -c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), -c pp 357-385. -c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly -c Restarted Arnoldi Iteration", Rice University Technical Report -c TR95-13, Department of Computational and Applied Mathematics. -c 3. B.N. Parlett, "The Symmetric Eigenvalue Problem". Prentice-Hall, -c 1980. -c 4. B.N. Parlett, B. Nour-Omid, "Towards a Black Box Lanczos Program", -c Computer Physics Communications, 53 (1989), pp 169-179. -c 5. B. Nour-Omid, B.N. Parlett, T. Ericson, P.S. Jensen, "How to -c Implement the Spectral Transformation", Math. Comp., 48 (1987), -c pp 663-673. -c 6. R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos -c Algorithm for Solving Sparse Symmetric Generalized Eigenproblems", -c SIAM J. Matr. Anal. Apps., January (1993). -c 7. L. Reichel, W.B. Gragg, "Algorithm 686: FORTRAN Subroutines -c for Updating the QR decomposition", ACM TOMS, December 1990, -c Volume 16 Number 4, pp 369-377. -c -c\Remarks -c 1. The converged Ritz values are always returned in increasing -c (algebraic) order. -c -c 2. Currently only HOWMNY = 'A' is implemented. It is included at this -c stage for the user who wants to incorporate it. -c -c\Routines called: -c ssesrt ARPACK routine that sorts an array X, and applies the -c corresponding permutation to a matrix A. -c ssortr ssortr ARPACK sorting routine. -c ivout ARPACK utility routine that prints integers. -c svout ARPACK utility routine that prints vectors. -c sgeqr2 LAPACK routine that computes the QR factorization of -c a matrix. -c slacpy LAPACK matrix copy routine. -c slamch LAPACK routine that determines machine constants. -c sorm2r LAPACK routine that applies an orthogonal matrix in -c factored form. -c ssteqr LAPACK routine that computes eigenvalues and eigenvectors -c of a tridiagonal matrix. -c sger Level 2 BLAS rank one update to a matrix. -c scopy Level 1 BLAS that copies one vector to another . -c snrm2 Level 1 BLAS that computes the norm of a vector. -c sscal Level 1 BLAS that scales a vector. -c sswap Level 1 BLAS that swaps the contents of two vectors. - -c\Authors -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Chao Yang Houston, Texas -c Dept. of Computational & -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\Revision history: -c 12/15/93: Version ' 2.1' -c -c\SCCS Information: @(#) -c FILE: seupd.F SID: 2.11 DATE OF SID: 04/10/01 RELEASE: 2 -c -c\EndLib -c -c----------------------------------------------------------------------- - subroutine sseupd(rvec , howmny, select, d , - & z , ldz , sigma , bmat , - & n , which , nev , tol , - & resid , ncv , v , ldv , - & iparam, ipntr , workd , workl, - & lworkl, info ) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - character bmat, howmny, which*2 - logical rvec - integer info, ldz, ldv, lworkl, n, ncv, nev - Real - & sigma, tol -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - integer iparam(7), ipntr(11) - logical select(ncv) - Real - & d(nev) , resid(n) , v(ldv,ncv), - & z(ldz, nev), workd(2*n), workl(lworkl) -c -c %------------% -c | Parameters | -c %------------% -c - Real - & one, zero - parameter (one = 1.0E+0 , zero = 0.0E+0 ) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - character type*6 - integer bounds , ierr , ih , ihb , ihd , - & iq , iw , j , k , ldh , - & ldq , mode , msglvl, nconv , next , - & ritz , irz , ibd , np , ishift, - & leftptr, rghtptr, numcnv, jj - Real - & bnorm2 , rnorm, temp, temp1, eps23 - logical reord -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external scopy , sger , sgeqr2, slacpy, sorm2r, sscal, - & ssesrt, ssteqr, sswap , svout , ivout , ssortr -c -c %--------------------% -c | External Functions | -c %--------------------% -c - Real - & snrm2, slamch - external snrm2, slamch -c -c %---------------------% -c | Intrinsic Functions | -c %---------------------% -c - intrinsic min -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c -c %------------------------% -c | Set default parameters | -c %------------------------% -c - msglvl = mseupd - mode = iparam(7) - nconv = iparam(5) - info = 0 -c -c %--------------% -c | Quick return | -c %--------------% -c - if (nconv .eq. 0) go to 9000 - ierr = 0 -c - if (nconv .le. 0) ierr = -14 - if (n .le. 0) ierr = -1 - if (nev .le. 0) ierr = -2 - if (ncv .le. nev .or. ncv .gt. n) ierr = -3 - if (which .ne. 'LM' .and. - & which .ne. 'SM' .and. - & which .ne. 'LA' .and. - & which .ne. 'SA' .and. - & which .ne. 'BE') ierr = -5 - if (bmat .ne. 'I' .and. bmat .ne. 'G') ierr = -6 - if ( (howmny .ne. 'A' .and. - & howmny .ne. 'P' .and. - & howmny .ne. 'S') .and. rvec ) - & ierr = -15 - if (rvec .and. howmny .eq. 'S') ierr = -16 -c - if (rvec .and. lworkl .lt. ncv**2+8*ncv) ierr = -7 -c - if (mode .eq. 1 .or. mode .eq. 2) then - type = 'REGULR' - else if (mode .eq. 3 ) then - type = 'SHIFTI' - else if (mode .eq. 4 ) then - type = 'BUCKLE' - else if (mode .eq. 5 ) then - type = 'CAYLEY' - else - ierr = -10 - end if - if (mode .eq. 1 .and. bmat .eq. 'G') ierr = -11 - if (nev .eq. 1 .and. which .eq. 'BE') ierr = -12 -c -c %------------% -c | Error Exit | -c %------------% -c - if (ierr .ne. 0) then - info = ierr - go to 9000 - end if -c -c %-------------------------------------------------------% -c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | -c | etc... and the remaining workspace. | -c | Also update pointer to be used on output. | -c | Memory is laid out as follows: | -c | workl(1:2*ncv) := generated tridiagonal matrix H | -c | The subdiagonal is stored in workl(2:ncv). | -c | The dead spot is workl(1) but upon exiting | -c | ssaupd stores the B-norm of the last residual | -c | vector in workl(1). We use this !!! | -c | workl(2*ncv+1:2*ncv+ncv) := ritz values | -c | The wanted values are in the first NCONV spots. | -c | workl(3*ncv+1:3*ncv+ncv) := computed Ritz estimates | -c | The wanted values are in the first NCONV spots. | -c | NOTE: workl(1:4*ncv) is set by ssaupd and is not | -c | modified by sseupd. | -c %-------------------------------------------------------% -c -c %-------------------------------------------------------% -c | The following is used and set by sseupd. | -c | workl(4*ncv+1:4*ncv+ncv) := used as workspace during | -c | computation of the eigenvectors of H. Stores | -c | the diagonal of H. Upon EXIT contains the NCV | -c | Ritz values of the original system. The first | -c | NCONV spots have the wanted values. If MODE = | -c | 1 or 2 then will equal workl(2*ncv+1:3*ncv). | -c | workl(5*ncv+1:5*ncv+ncv) := used as workspace during | -c | computation of the eigenvectors of H. Stores | -c | the subdiagonal of H. Upon EXIT contains the | -c | NCV corresponding Ritz estimates of the | -c | original system. The first NCONV spots have the | -c | wanted values. If MODE = 1,2 then will equal | -c | workl(3*ncv+1:4*ncv). | -c | workl(6*ncv+1:6*ncv+ncv*ncv) := orthogonal Q that is | -c | the eigenvector matrix for H as returned by | -c | ssteqr. Not referenced if RVEC = .False. | -c | Ordering follows that of workl(4*ncv+1:5*ncv) | -c | workl(6*ncv+ncv*ncv+1:6*ncv+ncv*ncv+2*ncv) := | -c | Workspace. Needed by ssteqr and by sseupd. | -c | GRAND total of NCV*(NCV+8) locations. | -c %-------------------------------------------------------% -c -c - ih = ipntr(5) - ritz = ipntr(6) - bounds = ipntr(7) - ldh = ncv - ldq = ncv - ihd = bounds + ldh - ihb = ihd + ldh - iq = ihb + ldh - iw = iq + ldh*ncv - next = iw + 2*ncv - ipntr(4) = next - ipntr(8) = ihd - ipntr(9) = ihb - ipntr(10) = iq -c -c %----------------------------------------% -c | irz points to the Ritz values computed | -c | by _seigt before exiting _saup2. | -c | ibd points to the Ritz estimates | -c | computed by _seigt before exiting | -c | _saup2. | -c %----------------------------------------% -c - irz = ipntr(11)+ncv - ibd = irz+ncv -c -c -c %---------------------------------% -c | Set machine dependent constant. | -c %---------------------------------% -c - eps23 = slamch('Epsilon-Machine') - eps23 = eps23**(2.0E+0 / 3.0E+0 ) -c -c %---------------------------------------% -c | RNORM is B-norm of the RESID(1:N). | -c | BNORM2 is the 2 norm of B*RESID(1:N). | -c | Upon exit of ssaupd WORKD(1:N) has | -c | B*RESID(1:N). | -c %---------------------------------------% -c - rnorm = workl(ih) - if (bmat .eq. 'I') then - bnorm2 = rnorm - else if (bmat .eq. 'G') then - bnorm2 = snrm2(n, workd, 1) - end if -c - if (msglvl .gt. 2) then - call svout(logfil, ncv, workl(irz), ndigit, - & '_seupd: Ritz values passed in from _SAUPD.') - call svout(logfil, ncv, workl(ibd), ndigit, - & '_seupd: Ritz estimates passed in from _SAUPD.') - end if -c - if (rvec) then -c - reord = .false. -c -c %---------------------------------------------------% -c | Use the temporary bounds array to store indices | -c | These will be used to mark the select array later | -c %---------------------------------------------------% -c - do 10 j = 1,ncv - workl(bounds+j-1) = j - select(j) = .false. - 10 continue -c -c %-------------------------------------% -c | Select the wanted Ritz values. | -c | Sort the Ritz values so that the | -c | wanted ones appear at the tailing | -c | NEV positions of workl(irr) and | -c | workl(iri). Move the corresponding | -c | error estimates in workl(bound) | -c | accordingly. | -c %-------------------------------------% -c - np = ncv - nev - ishift = 0 - call ssgets(ishift, which , nev , - & np , workl(irz) , workl(bounds), - & workl) -c - if (msglvl .gt. 2) then - call svout(logfil, ncv, workl(irz), ndigit, - & '_seupd: Ritz values after calling _SGETS.') - call svout(logfil, ncv, workl(bounds), ndigit, - & '_seupd: Ritz value indices after calling _SGETS.') - end if -c -c %-----------------------------------------------------% -c | Record indices of the converged wanted Ritz values | -c | Mark the select array for possible reordering | -c %-----------------------------------------------------% -c - numcnv = 0 - do 11 j = 1,ncv - temp1 = max(eps23, abs(workl(irz+ncv-j)) ) - jj = workl(bounds + ncv - j) - if (numcnv .lt. nconv .and. - & workl(ibd+jj-1) .le. tol*temp1) then - select(jj) = .true. - numcnv = numcnv + 1 - if (jj .gt. nev) reord = .true. - endif - 11 continue -c -c %-----------------------------------------------------------% -c | Check the count (numcnv) of converged Ritz values with | -c | the number (nconv) reported by _saupd. If these two | -c | are different then there has probably been an error | -c | caused by incorrect passing of the _saupd data. | -c %-----------------------------------------------------------% -c - if (msglvl .gt. 2) then - call ivout(logfil, 1, numcnv, ndigit, - & '_seupd: Number of specified eigenvalues') - call ivout(logfil, 1, nconv, ndigit, - & '_seupd: Number of "converged" eigenvalues') - end if -c - if (numcnv .ne. nconv) then - info = -17 - go to 9000 - end if -c -c %-----------------------------------------------------------% -c | Call LAPACK routine _steqr to compute the eigenvalues and | -c | eigenvectors of the final symmetric tridiagonal matrix H. | -c | Initialize the eigenvector matrix Q to the identity. | -c %-----------------------------------------------------------% -c - call scopy(ncv-1, workl(ih+1), 1, workl(ihb), 1) - call scopy(ncv, workl(ih+ldh), 1, workl(ihd), 1) -c - call ssteqr('Identity', ncv, workl(ihd), workl(ihb), - & workl(iq) , ldq, workl(iw), ierr) -c - if (ierr .ne. 0) then - info = -8 - go to 9000 - end if -c - if (msglvl .gt. 1) then - call scopy(ncv, workl(iq+ncv-1), ldq, workl(iw), 1) - call svout(logfil, ncv, workl(ihd), ndigit, - & '_seupd: NCV Ritz values of the final H matrix') - call svout(logfil, ncv, workl(iw), ndigit, - & '_seupd: last row of the eigenvector matrix for H') - end if -c - if (reord) then -c -c %---------------------------------------------% -c | Reordered the eigenvalues and eigenvectors | -c | computed by _steqr so that the "converged" | -c | eigenvalues appear in the first NCONV | -c | positions of workl(ihd), and the associated | -c | eigenvectors appear in the first NCONV | -c | columns. | -c %---------------------------------------------% -c - leftptr = 1 - rghtptr = ncv -c - if (ncv .eq. 1) go to 30 -c - 20 if (select(leftptr)) then -c -c %-------------------------------------------% -c | Search, from the left, for the first Ritz | -c | value that has not converged. | -c %-------------------------------------------% -c - leftptr = leftptr + 1 -c - else if ( .not. select(rghtptr)) then -c -c %----------------------------------------------% -c | Search, from the right, the first Ritz value | -c | that has converged. | -c %----------------------------------------------% -c - rghtptr = rghtptr - 1 -c - else -c -c %----------------------------------------------% -c | Swap the Ritz value on the left that has not | -c | converged with the Ritz value on the right | -c | that has converged. Swap the associated | -c | eigenvector of the tridiagonal matrix H as | -c | well. | -c %----------------------------------------------% -c - temp = workl(ihd+leftptr-1) - workl(ihd+leftptr-1) = workl(ihd+rghtptr-1) - workl(ihd+rghtptr-1) = temp - call scopy(ncv, workl(iq+ncv*(leftptr-1)), 1, - & workl(iw), 1) - call scopy(ncv, workl(iq+ncv*(rghtptr-1)), 1, - & workl(iq+ncv*(leftptr-1)), 1) - call scopy(ncv, workl(iw), 1, - & workl(iq+ncv*(rghtptr-1)), 1) - leftptr = leftptr + 1 - rghtptr = rghtptr - 1 -c - end if -c - if (leftptr .lt. rghtptr) go to 20 -c - end if -c - 30 if (msglvl .gt. 2) then - call svout (logfil, ncv, workl(ihd), ndigit, - & '_seupd: The eigenvalues of H--reordered') - end if -c -c %----------------------------------------% -c | Load the converged Ritz values into D. | -c %----------------------------------------% -c - call scopy(nconv, workl(ihd), 1, d, 1) -c - else -c -c %-----------------------------------------------------% -c | Ritz vectors not required. Load Ritz values into D. | -c %-----------------------------------------------------% -c - call scopy(nconv, workl(ritz), 1, d, 1) - call scopy(ncv, workl(ritz), 1, workl(ihd), 1) -c - end if -c -c %------------------------------------------------------------------% -c | Transform the Ritz values and possibly vectors and corresponding | -c | Ritz estimates of OP to those of A*x=lambda*B*x. The Ritz values | -c | (and corresponding data) are returned in ascending order. | -c %------------------------------------------------------------------% -c - if (type .eq. 'REGULR') then -c -c %---------------------------------------------------------% -c | Ascending sort of wanted Ritz values, vectors and error | -c | bounds. Not necessary if only Ritz values are desired. | -c %---------------------------------------------------------% -c - if (rvec) then - call ssesrt('LA', rvec , nconv, d, ncv, workl(iq), ldq) - else - call scopy(ncv, workl(bounds), 1, workl(ihb), 1) - end if -c - else -c -c %-------------------------------------------------------------% -c | * Make a copy of all the Ritz values. | -c | * Transform the Ritz values back to the original system. | -c | For TYPE = 'SHIFTI' the transformation is | -c | lambda = 1/theta + sigma | -c | For TYPE = 'BUCKLE' the transformation is | -c | lambda = sigma * theta / ( theta - 1 ) | -c | For TYPE = 'CAYLEY' the transformation is | -c | lambda = sigma * (theta + 1) / (theta - 1 ) | -c | where the theta are the Ritz values returned by ssaupd. | -c | NOTES: | -c | *The Ritz vectors are not affected by the transformation. | -c | They are only reordered. | -c %-------------------------------------------------------------% -c - call scopy (ncv, workl(ihd), 1, workl(iw), 1) - if (type .eq. 'SHIFTI') then - do 40 k=1, ncv - workl(ihd+k-1) = one / workl(ihd+k-1) + sigma - 40 continue - else if (type .eq. 'BUCKLE') then - do 50 k=1, ncv - workl(ihd+k-1) = sigma * workl(ihd+k-1) / - & (workl(ihd+k-1) - one) - 50 continue - else if (type .eq. 'CAYLEY') then - do 60 k=1, ncv - workl(ihd+k-1) = sigma * (workl(ihd+k-1) + one) / - & (workl(ihd+k-1) - one) - 60 continue - end if -c -c %-------------------------------------------------------------% -c | * Store the wanted NCONV lambda values into D. | -c | * Sort the NCONV wanted lambda in WORKL(IHD:IHD+NCONV-1) | -c | into ascending order and apply sort to the NCONV theta | -c | values in the transformed system. We will need this to | -c | compute Ritz estimates in the original system. | -c | * Finally sort the lambda`s into ascending order and apply | -c | to Ritz vectors if wanted. Else just sort lambda`s into | -c | ascending order. | -c | NOTES: | -c | *workl(iw:iw+ncv-1) contain the theta ordered so that they | -c | match the ordering of the lambda. We`ll use them again for | -c | Ritz vector purification. | -c %-------------------------------------------------------------% -c - call scopy(nconv, workl(ihd), 1, d, 1) - call ssortr('LA', .true., nconv, workl(ihd), workl(iw)) - if (rvec) then - call ssesrt('LA', rvec , nconv, d, ncv, workl(iq), ldq) - else - call scopy(ncv, workl(bounds), 1, workl(ihb), 1) - call sscal(ncv, bnorm2/rnorm, workl(ihb), 1) - call ssortr('LA', .true., nconv, d, workl(ihb)) - end if -c - end if -c -c %------------------------------------------------% -c | Compute the Ritz vectors. Transform the wanted | -c | eigenvectors of the symmetric tridiagonal H by | -c | the Lanczos basis matrix V. | -c %------------------------------------------------% -c - if (rvec .and. howmny .eq. 'A') then -c -c %----------------------------------------------------------% -c | Compute the QR factorization of the matrix representing | -c | the wanted invariant subspace located in the first NCONV | -c | columns of workl(iq,ldq). | -c %----------------------------------------------------------% -c - call sgeqr2(ncv, nconv , workl(iq) , - & ldq, workl(iw+ncv), workl(ihb), - & ierr) -c -c %--------------------------------------------------------% -c | * Postmultiply V by Q. | -c | * Copy the first NCONV columns of VQ into Z. | -c | The N by NCONV matrix Z is now a matrix representation | -c | of the approximate invariant subspace associated with | -c | the Ritz values in workl(ihd). | -c %--------------------------------------------------------% -c - call sorm2r('Right', 'Notranspose', n , - & ncv , nconv , workl(iq), - & ldq , workl(iw+ncv), v , - & ldv , workd(n+1) , ierr) - call slacpy('All', n, nconv, v, ldv, z, ldz) -c -c %-----------------------------------------------------% -c | In order to compute the Ritz estimates for the Ritz | -c | values in both systems, need the last row of the | -c | eigenvector matrix. Remember, it`s in factored form | -c %-----------------------------------------------------% -c - do 65 j = 1, ncv-1 - workl(ihb+j-1) = zero - 65 continue - workl(ihb+ncv-1) = one - call sorm2r('Left', 'Transpose' , ncv , - & 1 , nconv , workl(iq) , - & ldq , workl(iw+ncv), workl(ihb), - & ncv , temp , ierr) -c - else if (rvec .and. howmny .eq. 'S') then -c -c Not yet implemented. See remark 2 above. -c - end if -c - if (type .eq. 'REGULR' .and. rvec) then -c - do 70 j=1, ncv - workl(ihb+j-1) = rnorm * abs( workl(ihb+j-1) ) - 70 continue -c - else if (type .ne. 'REGULR' .and. rvec) then -c -c %-------------------------------------------------% -c | * Determine Ritz estimates of the theta. | -c | If RVEC = .true. then compute Ritz estimates | -c | of the theta. | -c | If RVEC = .false. then copy Ritz estimates | -c | as computed by ssaupd. | -c | * Determine Ritz estimates of the lambda. | -c %-------------------------------------------------% -c - call sscal (ncv, bnorm2, workl(ihb), 1) - if (type .eq. 'SHIFTI') then -c - do 80 k=1, ncv - workl(ihb+k-1) = abs( workl(ihb+k-1) ) - & / workl(iw+k-1)**2 - 80 continue -c - else if (type .eq. 'BUCKLE') then -c - do 90 k=1, ncv - workl(ihb+k-1) = sigma * abs( workl(ihb+k-1) ) - & / (workl(iw+k-1)-one )**2 - 90 continue -c - else if (type .eq. 'CAYLEY') then -c - do 100 k=1, ncv - workl(ihb+k-1) = abs( workl(ihb+k-1) - & / workl(iw+k-1)*(workl(iw+k-1)-one) ) - 100 continue -c - end if -c - end if -c - if (type .ne. 'REGULR' .and. msglvl .gt. 1) then - call svout(logfil, nconv, d, ndigit, - & '_seupd: Untransformed converged Ritz values') - call svout(logfil, nconv, workl(ihb), ndigit, - & '_seupd: Ritz estimates of the untransformed Ritz values') - else if (msglvl .gt. 1) then - call svout(logfil, nconv, d, ndigit, - & '_seupd: Converged Ritz values') - call svout(logfil, nconv, workl(ihb), ndigit, - & '_seupd: Associated Ritz estimates') - end if -c -c %-------------------------------------------------% -c | Ritz vector purification step. Formally perform | -c | one of inverse subspace iteration. Only used | -c | for MODE = 3,4,5. See reference 7 | -c %-------------------------------------------------% -c - if (rvec .and. (type .eq. 'SHIFTI' .or. type .eq. 'CAYLEY')) then -c - do 110 k=0, nconv-1 - workl(iw+k) = workl(iq+k*ldq+ncv-1) - & / workl(iw+k) - 110 continue -c - else if (rvec .and. type .eq. 'BUCKLE') then -c - do 120 k=0, nconv-1 - workl(iw+k) = workl(iq+k*ldq+ncv-1) - & / (workl(iw+k)-one) - 120 continue -c - end if -c - if (type .ne. 'REGULR') - & call sger (n, nconv, one, resid, 1, workl(iw), 1, z, ldz) -c - 9000 continue -c - return -c -c %---------------% -c | End of sseupd| -c %---------------% -c - end
--- a/libcruft/arpack/src/ssgets.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,219 +0,0 @@ -c----------------------------------------------------------------------- -c\BeginDoc -c -c\Name: ssgets -c -c\Description: -c Given the eigenvalues of the symmetric tridiagonal matrix H, -c computes the NP shifts AMU that are zeros of the polynomial of -c degree NP which filters out components of the unwanted eigenvectors -c corresponding to the AMU's based on some given criteria. -c -c NOTE: This is called even in the case of user specified shifts in -c order to sort the eigenvalues, and error bounds of H for later use. -c -c\Usage: -c call ssgets -c ( ISHIFT, WHICH, KEV, NP, RITZ, BOUNDS, SHIFTS ) -c -c\Arguments -c ISHIFT Integer. (INPUT) -c Method for selecting the implicit shifts at each iteration. -c ISHIFT = 0: user specified shifts -c ISHIFT = 1: exact shift with respect to the matrix H. -c -c WHICH Character*2. (INPUT) -c Shift selection criteria. -c 'LM' -> KEV eigenvalues of largest magnitude are retained. -c 'SM' -> KEV eigenvalues of smallest magnitude are retained. -c 'LA' -> KEV eigenvalues of largest value are retained. -c 'SA' -> KEV eigenvalues of smallest value are retained. -c 'BE' -> KEV eigenvalues, half from each end of the spectrum. -c If KEV is odd, compute one more from the high end. -c -c KEV Integer. (INPUT) -c KEV+NP is the size of the matrix H. -c -c NP Integer. (INPUT) -c Number of implicit shifts to be computed. -c -c RITZ Real array of length KEV+NP. (INPUT/OUTPUT) -c On INPUT, RITZ contains the eigenvalues of H. -c On OUTPUT, RITZ are sorted so that the unwanted eigenvalues -c are in the first NP locations and the wanted part is in -c the last KEV locations. When exact shifts are selected, the -c unwanted part corresponds to the shifts to be applied. -c -c BOUNDS Real array of length KEV+NP. (INPUT/OUTPUT) -c Error bounds corresponding to the ordering in RITZ. -c -c SHIFTS Real array of length NP. (INPUT/OUTPUT) -c On INPUT: contains the user specified shifts if ISHIFT = 0. -c On OUTPUT: contains the shifts sorted into decreasing order -c of magnitude with respect to the Ritz estimates contained in -c BOUNDS. If ISHIFT = 0, SHIFTS is not modified on exit. -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Local variables: -c xxxxxx real -c -c\Routines called: -c ssortr ARPACK utility sorting routine. -c ivout ARPACK utility routine that prints integers. -c arscnd ARPACK utility routine for timing. -c svout ARPACK utility routine that prints vectors. -c scopy Level 1 BLAS that copies one vector to another. -c sswap Level 1 BLAS that swaps the contents of two vectors. -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\Revision history: -c xx/xx/93: Version ' 2.1' -c -c\SCCS Information: @(#) -c FILE: sgets.F SID: 2.4 DATE OF SID: 4/19/96 RELEASE: 2 -c -c\Remarks -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine ssgets ( ishift, which, kev, np, ritz, bounds, shifts ) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - character*2 which - integer ishift, kev, np -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - Real - & bounds(kev+np), ritz(kev+np), shifts(np) -c -c %------------% -c | Parameters | -c %------------% -c - Real - & one, zero - parameter (one = 1.0E+0, zero = 0.0E+0) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - integer kevd2, msglvl -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external sswap, scopy, ssortr, arscnd -c -c %---------------------% -c | Intrinsic Functions | -c %---------------------% -c - intrinsic max, min -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c -c %-------------------------------% -c | Initialize timing statistics | -c | & message level for debugging | -c %-------------------------------% -c - call arscnd (t0) - msglvl = msgets -c - if (which .eq. 'BE') then -c -c %-----------------------------------------------------% -c | Both ends of the spectrum are requested. | -c | Sort the eigenvalues into algebraically increasing | -c | order first then swap high end of the spectrum next | -c | to low end in appropriate locations. | -c | NOTE: when np < floor(kev/2) be careful not to swap | -c | overlapping locations. | -c %-----------------------------------------------------% -c - call ssortr ('LA', .true., kev+np, ritz, bounds) - kevd2 = kev / 2 - if ( kev .gt. 1 ) then - call sswap ( min(kevd2,np), ritz, 1, - & ritz( max(kevd2,np)+1 ), 1) - call sswap ( min(kevd2,np), bounds, 1, - & bounds( max(kevd2,np)+1 ), 1) - end if -c - else -c -c %----------------------------------------------------% -c | LM, SM, LA, SA case. | -c | Sort the eigenvalues of H into the desired order | -c | and apply the resulting order to BOUNDS. | -c | The eigenvalues are sorted so that the wanted part | -c | are always in the last KEV locations. | -c %----------------------------------------------------% -c - call ssortr (which, .true., kev+np, ritz, bounds) - end if -c - if (ishift .eq. 1 .and. np .gt. 0) then -c -c %-------------------------------------------------------% -c | Sort the unwanted Ritz values used as shifts so that | -c | the ones with largest Ritz estimates are first. | -c | This will tend to minimize the effects of the | -c | forward instability of the iteration when the shifts | -c | are applied in subroutine ssapps. | -c %-------------------------------------------------------% -c - call ssortr ('SM', .true., np, bounds, ritz) - call scopy (np, ritz, 1, shifts, 1) - end if -c - call arscnd (t1) - tsgets = tsgets + (t1 - t0) -c - if (msglvl .gt. 0) then - call ivout (logfil, 1, kev, ndigit, '_sgets: KEV is') - call ivout (logfil, 1, np, ndigit, '_sgets: NP is') - call svout (logfil, kev+np, ritz, ndigit, - & '_sgets: Eigenvalues of current H matrix') - call svout (logfil, kev+np, bounds, ndigit, - & '_sgets: Associated Ritz estimates') - end if -c - return -c -c %---------------% -c | End of ssgets | -c %---------------% -c - end
--- a/libcruft/arpack/src/ssortc.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,344 +0,0 @@ -c----------------------------------------------------------------------- -c\BeginDoc -c -c\Name: ssortc -c -c\Description: -c Sorts the complex array in XREAL and XIMAG into the order -c specified by WHICH and optionally applies the permutation to the -c real array Y. It is assumed that if an element of XIMAG is -c nonzero, then its negative is also an element. In other words, -c both members of a complex conjugate pair are to be sorted and the -c pairs are kept adjacent to each other. -c -c\Usage: -c call ssortc -c ( WHICH, APPLY, N, XREAL, XIMAG, Y ) -c -c\Arguments -c WHICH Character*2. (Input) -c 'LM' -> sort XREAL,XIMAG into increasing order of magnitude. -c 'SM' -> sort XREAL,XIMAG into decreasing order of magnitude. -c 'LR' -> sort XREAL into increasing order of algebraic. -c 'SR' -> sort XREAL into decreasing order of algebraic. -c 'LI' -> sort XIMAG into increasing order of magnitude. -c 'SI' -> sort XIMAG into decreasing order of magnitude. -c NOTE: If an element of XIMAG is non-zero, then its negative -c is also an element. -c -c APPLY Logical. (Input) -c APPLY = .TRUE. -> apply the sorted order to array Y. -c APPLY = .FALSE. -> do not apply the sorted order to array Y. -c -c N Integer. (INPUT) -c Size of the arrays. -c -c XREAL, Real array of length N. (INPUT/OUTPUT) -c XIMAG Real and imaginary part of the array to be sorted. -c -c Y Real array of length N. (INPUT/OUTPUT) -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\Revision history: -c xx/xx/92: Version ' 2.1' -c Adapted from the sort routine in LANSO. -c -c\SCCS Information: @(#) -c FILE: sortc.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2 -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine ssortc (which, apply, n, xreal, ximag, y) -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - character*2 which - logical apply - integer n -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - Real - & xreal(0:n-1), ximag(0:n-1), y(0:n-1) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - integer i, igap, j - Real - & temp, temp1, temp2 -c -c %--------------------% -c | External Functions | -c %--------------------% -c - Real - & slapy2 - external slapy2 -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c - igap = n / 2 -c - if (which .eq. 'LM') then -c -c %------------------------------------------------------% -c | Sort XREAL,XIMAG into increasing order of magnitude. | -c %------------------------------------------------------% -c - 10 continue - if (igap .eq. 0) go to 9000 -c - do 30 i = igap, n-1 - j = i-igap - 20 continue -c - if (j.lt.0) go to 30 -c - temp1 = slapy2(xreal(j),ximag(j)) - temp2 = slapy2(xreal(j+igap),ximag(j+igap)) -c - if (temp1.gt.temp2) then - temp = xreal(j) - xreal(j) = xreal(j+igap) - xreal(j+igap) = temp -c - temp = ximag(j) - ximag(j) = ximag(j+igap) - ximag(j+igap) = temp -c - if (apply) then - temp = y(j) - y(j) = y(j+igap) - y(j+igap) = temp - end if - else - go to 30 - end if - j = j-igap - go to 20 - 30 continue - igap = igap / 2 - go to 10 -c - else if (which .eq. 'SM') then -c -c %------------------------------------------------------% -c | Sort XREAL,XIMAG into decreasing order of magnitude. | -c %------------------------------------------------------% -c - 40 continue - if (igap .eq. 0) go to 9000 -c - do 60 i = igap, n-1 - j = i-igap - 50 continue -c - if (j .lt. 0) go to 60 -c - temp1 = slapy2(xreal(j),ximag(j)) - temp2 = slapy2(xreal(j+igap),ximag(j+igap)) -c - if (temp1.lt.temp2) then - temp = xreal(j) - xreal(j) = xreal(j+igap) - xreal(j+igap) = temp -c - temp = ximag(j) - ximag(j) = ximag(j+igap) - ximag(j+igap) = temp -c - if (apply) then - temp = y(j) - y(j) = y(j+igap) - y(j+igap) = temp - end if - else - go to 60 - endif - j = j-igap - go to 50 - 60 continue - igap = igap / 2 - go to 40 -c - else if (which .eq. 'LR') then -c -c %------------------------------------------------% -c | Sort XREAL into increasing order of algebraic. | -c %------------------------------------------------% -c - 70 continue - if (igap .eq. 0) go to 9000 -c - do 90 i = igap, n-1 - j = i-igap - 80 continue -c - if (j.lt.0) go to 90 -c - if (xreal(j).gt.xreal(j+igap)) then - temp = xreal(j) - xreal(j) = xreal(j+igap) - xreal(j+igap) = temp -c - temp = ximag(j) - ximag(j) = ximag(j+igap) - ximag(j+igap) = temp -c - if (apply) then - temp = y(j) - y(j) = y(j+igap) - y(j+igap) = temp - end if - else - go to 90 - endif - j = j-igap - go to 80 - 90 continue - igap = igap / 2 - go to 70 -c - else if (which .eq. 'SR') then -c -c %------------------------------------------------% -c | Sort XREAL into decreasing order of algebraic. | -c %------------------------------------------------% -c - 100 continue - if (igap .eq. 0) go to 9000 - do 120 i = igap, n-1 - j = i-igap - 110 continue -c - if (j.lt.0) go to 120 -c - if (xreal(j).lt.xreal(j+igap)) then - temp = xreal(j) - xreal(j) = xreal(j+igap) - xreal(j+igap) = temp -c - temp = ximag(j) - ximag(j) = ximag(j+igap) - ximag(j+igap) = temp -c - if (apply) then - temp = y(j) - y(j) = y(j+igap) - y(j+igap) = temp - end if - else - go to 120 - endif - j = j-igap - go to 110 - 120 continue - igap = igap / 2 - go to 100 -c - else if (which .eq. 'LI') then -c -c %------------------------------------------------% -c | Sort XIMAG into increasing order of magnitude. | -c %------------------------------------------------% -c - 130 continue - if (igap .eq. 0) go to 9000 - do 150 i = igap, n-1 - j = i-igap - 140 continue -c - if (j.lt.0) go to 150 -c - if (abs(ximag(j)).gt.abs(ximag(j+igap))) then - temp = xreal(j) - xreal(j) = xreal(j+igap) - xreal(j+igap) = temp -c - temp = ximag(j) - ximag(j) = ximag(j+igap) - ximag(j+igap) = temp -c - if (apply) then - temp = y(j) - y(j) = y(j+igap) - y(j+igap) = temp - end if - else - go to 150 - endif - j = j-igap - go to 140 - 150 continue - igap = igap / 2 - go to 130 -c - else if (which .eq. 'SI') then -c -c %------------------------------------------------% -c | Sort XIMAG into decreasing order of magnitude. | -c %------------------------------------------------% -c - 160 continue - if (igap .eq. 0) go to 9000 - do 180 i = igap, n-1 - j = i-igap - 170 continue -c - if (j.lt.0) go to 180 -c - if (abs(ximag(j)).lt.abs(ximag(j+igap))) then - temp = xreal(j) - xreal(j) = xreal(j+igap) - xreal(j+igap) = temp -c - temp = ximag(j) - ximag(j) = ximag(j+igap) - ximag(j+igap) = temp -c - if (apply) then - temp = y(j) - y(j) = y(j+igap) - y(j+igap) = temp - end if - else - go to 180 - endif - j = j-igap - go to 170 - 180 continue - igap = igap / 2 - go to 160 - end if -c - 9000 continue - return -c -c %---------------% -c | End of ssortc | -c %---------------% -c - end
--- a/libcruft/arpack/src/ssortr.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,218 +0,0 @@ -c----------------------------------------------------------------------- -c\BeginDoc -c -c\Name: ssortr -c -c\Description: -c Sort the array X1 in the order specified by WHICH and optionally -c applies the permutation to the array X2. -c -c\Usage: -c call ssortr -c ( WHICH, APPLY, N, X1, X2 ) -c -c\Arguments -c WHICH Character*2. (Input) -c 'LM' -> X1 is sorted into increasing order of magnitude. -c 'SM' -> X1 is sorted into decreasing order of magnitude. -c 'LA' -> X1 is sorted into increasing order of algebraic. -c 'SA' -> X1 is sorted into decreasing order of algebraic. -c -c APPLY Logical. (Input) -c APPLY = .TRUE. -> apply the sorted order to X2. -c APPLY = .FALSE. -> do not apply the sorted order to X2. -c -c N Integer. (INPUT) -c Size of the arrays. -c -c X1 Real array of length N. (INPUT/OUTPUT) -c The array to be sorted. -c -c X2 Real array of length N. (INPUT/OUTPUT) -c Only referenced if APPLY = .TRUE. -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\Revision history: -c 12/16/93: Version ' 2.1'. -c Adapted from the sort routine in LANSO. -c -c\SCCS Information: @(#) -c FILE: sortr.F SID: 2.3 DATE OF SID: 4/19/96 RELEASE: 2 -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine ssortr (which, apply, n, x1, x2) -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - character*2 which - logical apply - integer n -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - Real - & x1(0:n-1), x2(0:n-1) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - integer i, igap, j - Real - & temp -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c - igap = n / 2 -c - if (which .eq. 'SA') then -c -c X1 is sorted into decreasing order of algebraic. -c - 10 continue - if (igap .eq. 0) go to 9000 - do 30 i = igap, n-1 - j = i-igap - 20 continue -c - if (j.lt.0) go to 30 -c - if (x1(j).lt.x1(j+igap)) then - temp = x1(j) - x1(j) = x1(j+igap) - x1(j+igap) = temp - if (apply) then - temp = x2(j) - x2(j) = x2(j+igap) - x2(j+igap) = temp - end if - else - go to 30 - endif - j = j-igap - go to 20 - 30 continue - igap = igap / 2 - go to 10 -c - else if (which .eq. 'SM') then -c -c X1 is sorted into decreasing order of magnitude. -c - 40 continue - if (igap .eq. 0) go to 9000 - do 60 i = igap, n-1 - j = i-igap - 50 continue -c - if (j.lt.0) go to 60 -c - if (abs(x1(j)).lt.abs(x1(j+igap))) then - temp = x1(j) - x1(j) = x1(j+igap) - x1(j+igap) = temp - if (apply) then - temp = x2(j) - x2(j) = x2(j+igap) - x2(j+igap) = temp - end if - else - go to 60 - endif - j = j-igap - go to 50 - 60 continue - igap = igap / 2 - go to 40 -c - else if (which .eq. 'LA') then -c -c X1 is sorted into increasing order of algebraic. -c - 70 continue - if (igap .eq. 0) go to 9000 - do 90 i = igap, n-1 - j = i-igap - 80 continue -c - if (j.lt.0) go to 90 -c - if (x1(j).gt.x1(j+igap)) then - temp = x1(j) - x1(j) = x1(j+igap) - x1(j+igap) = temp - if (apply) then - temp = x2(j) - x2(j) = x2(j+igap) - x2(j+igap) = temp - end if - else - go to 90 - endif - j = j-igap - go to 80 - 90 continue - igap = igap / 2 - go to 70 -c - else if (which .eq. 'LM') then -c -c X1 is sorted into increasing order of magnitude. -c - 100 continue - if (igap .eq. 0) go to 9000 - do 120 i = igap, n-1 - j = i-igap - 110 continue -c - if (j.lt.0) go to 120 -c - if (abs(x1(j)).gt.abs(x1(j+igap))) then - temp = x1(j) - x1(j) = x1(j+igap) - x1(j+igap) = temp - if (apply) then - temp = x2(j) - x2(j) = x2(j+igap) - x2(j+igap) = temp - end if - else - go to 120 - endif - j = j-igap - go to 110 - 120 continue - igap = igap / 2 - go to 100 - end if -c - 9000 continue - return -c -c %---------------% -c | End of ssortr | -c %---------------% -c - end
--- a/libcruft/arpack/src/sstatn.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,61 +0,0 @@ -c -c %---------------------------------------------% -c | Initialize statistic and timing information | -c | for nonsymmetric Arnoldi code. | -c %---------------------------------------------% -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\SCCS Information: @(#) -c FILE: statn.F SID: 2.4 DATE OF SID: 4/20/96 RELEASE: 2 -c - subroutine sstatn -c -c %--------------------------------% -c | See stat.doc for documentation | -c %--------------------------------% -c - include 'stat.h' -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c - nopx = 0 - nbx = 0 - nrorth = 0 - nitref = 0 - nrstrt = 0 -c - tnaupd = 0.0E+0 - tnaup2 = 0.0E+0 - tnaitr = 0.0E+0 - tneigh = 0.0E+0 - tngets = 0.0E+0 - tnapps = 0.0E+0 - tnconv = 0.0E+0 - titref = 0.0E+0 - tgetv0 = 0.0E+0 - trvec = 0.0E+0 -c -c %----------------------------------------------------% -c | User time including reverse communication overhead | -c %----------------------------------------------------% -c - tmvopx = 0.0E+0 - tmvbx = 0.0E+0 -c - return -c -c -c %---------------% -c | End of sstatn | -c %---------------% -c - end
--- a/libcruft/arpack/src/sstats.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,47 +0,0 @@ -c -c\SCCS Information: @(#) -c FILE: stats.F SID: 2.1 DATE OF SID: 4/19/96 RELEASE: 2 -c %---------------------------------------------% -c | Initialize statistic and timing information | -c | for symmetric Arnoldi code. | -c %---------------------------------------------% - - subroutine sstats - -c %--------------------------------% -c | See stat.doc for documentation | -c %--------------------------------% - include 'stat.h' - -c %-----------------------% -c | Executable Statements | -c %-----------------------% - - nopx = 0 - nbx = 0 - nrorth = 0 - nitref = 0 - nrstrt = 0 - - tsaupd = 0.0E+0 - tsaup2 = 0.0E+0 - tsaitr = 0.0E+0 - tseigt = 0.0E+0 - tsgets = 0.0E+0 - tsapps = 0.0E+0 - tsconv = 0.0E+0 - titref = 0.0E+0 - tgetv0 = 0.0E+0 - trvec = 0.0E+0 - -c %----------------------------------------------------% -c | User time including reverse communication overhead | -c %----------------------------------------------------% - tmvopx = 0.0E+0 - tmvbx = 0.0E+0 - - return -c -c End of sstats -c - end
--- a/libcruft/arpack/src/sstqrb.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,594 +0,0 @@ -c----------------------------------------------------------------------- -c\BeginDoc -c -c\Name: sstqrb -c -c\Description: -c Computes all eigenvalues and the last component of the eigenvectors -c of a symmetric tridiagonal matrix using the implicit QL or QR method. -c -c This is mostly a modification of the LAPACK routine ssteqr. -c See Remarks. -c -c\Usage: -c call sstqrb -c ( N, D, E, Z, WORK, INFO ) -c -c\Arguments -c N Integer. (INPUT) -c The number of rows and columns in the matrix. N >= 0. -c -c D Real array, dimension (N). (INPUT/OUTPUT) -c On entry, D contains the diagonal elements of the -c tridiagonal matrix. -c On exit, D contains the eigenvalues, in ascending order. -c If an error exit is made, the eigenvalues are correct -c for indices 1,2,...,INFO-1, but they are unordered and -c may not be the smallest eigenvalues of the matrix. -c -c E Real array, dimension (N-1). (INPUT/OUTPUT) -c On entry, E contains the subdiagonal elements of the -c tridiagonal matrix in positions 1 through N-1. -c On exit, E has been destroyed. -c -c Z Real array, dimension (N). (OUTPUT) -c On exit, Z contains the last row of the orthonormal -c eigenvector matrix of the symmetric tridiagonal matrix. -c If an error exit is made, Z contains the last row of the -c eigenvector matrix associated with the stored eigenvalues. -c -c WORK Real array, dimension (max(1,2*N-2)). (WORKSPACE) -c Workspace used in accumulating the transformation for -c computing the last components of the eigenvectors. -c -c INFO Integer. (OUTPUT) -c = 0: normal return. -c < 0: if INFO = -i, the i-th argument had an illegal value. -c > 0: if INFO = +i, the i-th eigenvalue has not converged -c after a total of 30*N iterations. -c -c\Remarks -c 1. None. -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Local variables: -c xxxxxx real -c -c\Routines called: -c saxpy Level 1 BLAS that computes a vector triad. -c scopy Level 1 BLAS that copies one vector to another. -c sswap Level 1 BLAS that swaps the contents of two vectors. -c lsame LAPACK character comparison routine. -c slae2 LAPACK routine that computes the eigenvalues of a 2-by-2 -c symmetric matrix. -c slaev2 LAPACK routine that eigendecomposition of a 2-by-2 symmetric -c matrix. -c slamch LAPACK routine that determines machine constants. -c slanst LAPACK routine that computes the norm of a matrix. -c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. -c slartg LAPACK Givens rotation construction routine. -c slascl LAPACK routine for careful scaling of a matrix. -c slaset LAPACK matrix initialization routine. -c slasr LAPACK routine that applies an orthogonal transformation to -c a matrix. -c slasrt LAPACK sorting routine. -c ssteqr LAPACK routine that computes eigenvalues and eigenvectors -c of a symmetric tridiagonal matrix. -c xerbla LAPACK error handler routine. -c -c\Authors -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\SCCS Information: @(#) -c FILE: stqrb.F SID: 2.5 DATE OF SID: 8/27/96 RELEASE: 2 -c -c\Remarks -c 1. Starting with version 2.5, this routine is a modified version -c of LAPACK version 2.0 subroutine SSTEQR. No lines are deleted, -c only commeted out and new lines inserted. -c All lines commented out have "c$$$" at the beginning. -c Note that the LAPACK version 1.0 subroutine SSTEQR contained -c bugs. -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine sstqrb ( n, d, e, z, work, info ) -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - integer info, n -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - Real - & d( n ), e( n-1 ), z( n ), work( 2*n-2 ) -c -c .. parameters .. - Real - & zero, one, two, three - parameter ( zero = 0.0E+0, one = 1.0E+0, - & two = 2.0E+0, three = 3.0E+0 ) - integer maxit - parameter ( maxit = 30 ) -c .. -c .. 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 -c .. -c .. external functions .. - logical lsame - Real - & slamch, slanst, slapy2 - external lsame, slamch, slanst, slapy2 -c .. -c .. external subroutines .. - external slae2, slaev2, slartg, slascl, slaset, slasr, - & slasrt, sswap, xerbla -c .. -c .. intrinsic functions .. - intrinsic abs, max, sign, sqrt -c .. -c .. executable statements .. -c -c test the input parameters. -c - info = 0 -c -c$$$ IF( LSAME( COMPZ, 'N' ) ) THEN -c$$$ ICOMPZ = 0 -c$$$ ELSE IF( LSAME( COMPZ, 'V' ) ) THEN -c$$$ ICOMPZ = 1 -c$$$ ELSE IF( LSAME( COMPZ, 'I' ) ) THEN -c$$$ ICOMPZ = 2 -c$$$ ELSE -c$$$ ICOMPZ = -1 -c$$$ END IF -c$$$ IF( ICOMPZ.LT.0 ) THEN -c$$$ INFO = -1 -c$$$ ELSE IF( N.LT.0 ) THEN -c$$$ INFO = -2 -c$$$ ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, -c$$$ $ N ) ) ) THEN -c$$$ INFO = -6 -c$$$ END IF -c$$$ IF( INFO.NE.0 ) THEN -c$$$ CALL XERBLA( 'SSTEQR', -INFO ) -c$$$ RETURN -c$$$ END IF -c -c *** New starting with version 2.5 *** -c - icompz = 2 -c ************************************* -c -c quick return if possible -c - if( n.eq.0 ) - $ return -c - if( n.eq.1 ) then - if( icompz.eq.2 ) z( 1 ) = one - return - end if -c -c determine the unit roundoff and over/underflow thresholds. -c - eps = slamch( 'e' ) - eps2 = eps**2 - safmin = slamch( 's' ) - safmax = one / safmin - ssfmax = sqrt( safmax ) / three - ssfmin = sqrt( safmin ) / eps2 -c -c compute the eigenvalues and eigenvectors of the tridiagonal -c matrix. -c -c$$ if( icompz.eq.2 ) -c$$$ $ call slaset( 'full', n, n, zero, one, z, ldz ) -c -c *** New starting with version 2.5 *** -c - if ( icompz .eq. 2 ) then - do 5 j = 1, n-1 - z(j) = zero - 5 continue - z( n ) = one - end if -c ************************************* -c - nmaxit = n*maxit - jtot = 0 -c -c determine where the matrix splits and choose ql or qr iteration -c for each block, according to whether top or bottom diagonal -c element is smaller. -c - l1 = 1 - nm1 = n - 1 -c - 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 -c - 30 continue - l = l1 - lsv = l - lend = m - lendsv = lend - l1 = m + 1 - if( lend.eq.l ) - $ go to 10 -c -c scale submatrix in rows and columns l to lend -c - 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 -c -c choose between ql and qr iteration -c - if( abs( d( lend ) ).lt.abs( d( l ) ) ) then - lend = lsv - l = lendsv - end if -c - if( lend.gt.l ) then -c -c ql iteration -c -c look for small subdiagonal element. -c - 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 -c - m = lend -c - 60 continue - if( m.lt.lend ) - $ e( m ) = zero - p = d( l ) - if( m.eq.l ) - $ go to 80 -c -c if remaining matrix is 2-by-2, use slae2 or slaev2 -c to compute its eigensystem. -c - 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 -c$$$ call slasr( 'r', 'v', 'b', n, 2, work( l ), -c$$$ $ work( n-1+l ), z( 1, l ), ldz ) -c -c *** New starting with version 2.5 *** -c - tst = z(l+1) - z(l+1) = c*tst - s*z(l) - z(l) = s*tst + c*z(l) -c ************************************* - 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 -c - if( jtot.eq.nmaxit ) - $ go to 140 - jtot = jtot + 1 -c -c form shift. -c - g = ( d( l+1 )-p ) / ( two*e( l ) ) - r = slapy2( g, one ) - g = d( m ) - p + ( e( l ) / ( g+sign( r, g ) ) ) -c - s = one - c = one - p = zero -c -c inner loop -c - 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 -c -c if eigenvectors are desired, then save rotations. -c - if( icompz.gt.0 ) then - work( i ) = c - work( n-1+i ) = -s - end if -c - 70 continue -c -c if eigenvectors are desired, then apply saved rotations. -c - if( icompz.gt.0 ) then - mm = m - l + 1 -c$$$ call slasr( 'r', 'v', 'b', n, mm, work( l ), work( n-1+l ), -c$$$ $ z( 1, l ), ldz ) -c -c *** New starting with version 2.5 *** -c - call slasr( 'r', 'v', 'b', 1, mm, work( l ), - & work( n-1+l ), z( l ), 1 ) -c ************************************* - end if -c - d( l ) = d( l ) - p - e( l ) = g - go to 40 -c -c eigenvalue found. -c - 80 continue - d( l ) = p -c - l = l + 1 - if( l.le.lend ) - $ go to 40 - go to 140 -c - else -c -c qr iteration -c -c look for small superdiagonal element. -c - 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 -c - m = lend -c - 110 continue - if( m.gt.lend ) - $ e( m-1 ) = zero - p = d( l ) - if( m.eq.l ) - $ go to 130 -c -c if remaining matrix is 2-by-2, use slae2 or slaev2 -c to compute its eigensystem. -c - 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 ) -c$$$ work( m ) = c -c$$$ work( n-1+m ) = s -c$$$ call slasr( 'r', 'v', 'f', n, 2, work( m ), -c$$$ $ work( n-1+m ), z( 1, l-1 ), ldz ) -c -c *** New starting with version 2.5 *** -c - tst = z(l) - z(l) = c*tst - s*z(l-1) - z(l-1) = s*tst + c*z(l-1) -c ************************************* - 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 -c - if( jtot.eq.nmaxit ) - $ go to 140 - jtot = jtot + 1 -c -c form shift. -c - g = ( d( l-1 )-p ) / ( two*e( l-1 ) ) - r = slapy2( g, one ) - g = d( m ) - p + ( e( l-1 ) / ( g+sign( r, g ) ) ) -c - s = one - c = one - p = zero -c -c inner loop -c - 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 -c -c if eigenvectors are desired, then save rotations. -c - if( icompz.gt.0 ) then - work( i ) = c - work( n-1+i ) = s - end if -c - 120 continue -c -c if eigenvectors are desired, then apply saved rotations. -c - if( icompz.gt.0 ) then - mm = l - m + 1 -c$$$ call slasr( 'r', 'v', 'f', n, mm, work( m ), work( n-1+m ), -c$$$ $ z( 1, m ), ldz ) -c -c *** New starting with version 2.5 *** -c - call slasr( 'r', 'v', 'f', 1, mm, work( m ), work( n-1+m ), - & z( m ), 1 ) -c ************************************* - end if -c - d( l ) = d( l ) - p - e( lm1 ) = g - go to 90 -c -c eigenvalue found. -c - 130 continue - d( l ) = p -c - l = l - 1 - if( l.ge.lend ) - $ go to 90 - go to 140 -c - end if -c -c undo scaling if necessary -c - 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 -c -c check for no convergence to an eigenvalue after a total -c of n*maxit iterations. -c - 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 -c -c order eigenvalues and eigenvectors. -c - 160 continue - if( icompz.eq.0 ) then -c -c use quick sort -c - call slasrt( 'i', n, d, info ) -c - else -c -c use selection sort to minimize swaps of eigenvectors -c - 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 -c$$$ call sswap( n, z( 1, i ), 1, z( 1, k ), 1 ) -c *** New starting with version 2.5 *** -c - p = z(k) - z(k) = z(i) - z(i) = p -c ************************************* - end if - 180 continue - end if -c - 190 continue - return -c -c %---------------% -c | End of sstqrb | -c %---------------% -c - end
--- a/libcruft/arpack/src/stat.h Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,21 +0,0 @@ -c %--------------------------------% -c | See stat.doc for documentation | -c %--------------------------------% -c -c\SCCS Information: @(#) -c FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 -c - real t0, t1, t2, t3, t4, t5 - save t0, t1, t2, t3, t4, t5 -c - integer nopx, nbx, nrorth, nitref, nrstrt - real tsaupd, tsaup2, tsaitr, tseigt, tsgets, tsapps, tsconv, - & tnaupd, tnaup2, tnaitr, tneigh, tngets, tnapps, tnconv, - & tcaupd, tcaup2, tcaitr, tceigh, tcgets, tcapps, tcconv, - & tmvopx, tmvbx, tgetv0, titref, trvec - common /timing/ - & nopx, nbx, nrorth, nitref, nrstrt, - & tsaupd, tsaup2, tsaitr, tseigt, tsgets, tsapps, tsconv, - & tnaupd, tnaup2, tnaitr, tneigh, tngets, tnapps, tnconv, - & tcaupd, tcaup2, tcaitr, tceigh, tcgets, tcapps, tcconv, - & tmvopx, tmvbx, tgetv0, titref, trvec
--- a/libcruft/arpack/src/version.h Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,30 +0,0 @@ -/* - - In the current version, the parameter KAPPA in the Kahan's test - for orthogonality is set to 0.717, the same as used by Gragg & Reichel. - However computational experience indicates that this is a little too - strict and will frequently force reorthogonalization when it is not - necessary to do so. - - Also the "moving boundary" idea is not currently activated in the nonsymmetric - code since it is not conclusive that it's the right thing to do all the time. - Requires further investigation. - - As of 02/01/93 Richard Lehoucq assumes software control of the codes from - Phuong Vu. On 03/01/93 all the *.F files were migrated SCCS. The 1.1 version - of codes are those received from Phuong Vu. The frozen version of 07/08/92 - is now considered version 1.1. - - Version 2.1 contains two new symmetric routines, sesrt and seupd. - Changes as well as bug fixes for version 1.1 codes that were only corrected - for programming bugs are version 1.2. These 1.2 versions will also be in version 2.1. - Subroutine [d,s]saupd now requires slightly more workspace. See [d,s]saupd for the - details. - - \SCCS Information: @(#) - FILE: version.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 - - */ - -#define VERSION_NUMBER ' 2.1' -#define VERSION_DATE ' 11/15/95'
--- a/libcruft/arpack/src/zgetv0.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,414 +0,0 @@ -c\BeginDoc -c -c\Name: zgetv0 -c -c\Description: -c Generate a random initial residual vector for the Arnoldi process. -c Force the residual vector to be in the range of the operator OP. -c -c\Usage: -c call zgetv0 -c ( IDO, BMAT, ITRY, INITV, N, J, V, LDV, RESID, RNORM, -c IPNTR, WORKD, IERR ) -c -c\Arguments -c IDO Integer. (INPUT/OUTPUT) -c Reverse communication flag. IDO must be zero on the first -c call to zgetv0. -c ------------------------------------------------------------- -c IDO = 0: first call to the reverse communication interface -c IDO = -1: compute Y = OP * X where -c IPNTR(1) is the pointer into WORKD for X, -c IPNTR(2) is the pointer into WORKD for Y. -c This is for the initialization phase to force the -c starting vector into the range of OP. -c IDO = 2: compute Y = B * X where -c IPNTR(1) is the pointer into WORKD for X, -c IPNTR(2) is the pointer into WORKD for Y. -c IDO = 99: done -c ------------------------------------------------------------- -c -c BMAT Character*1. (INPUT) -c BMAT specifies the type of the matrix B in the (generalized) -c eigenvalue problem A*x = lambda*B*x. -c B = 'I' -> standard eigenvalue problem A*x = lambda*x -c B = 'G' -> generalized eigenvalue problem A*x = lambda*B*x -c -c ITRY Integer. (INPUT) -c ITRY counts the number of times that zgetv0 is called. -c It should be set to 1 on the initial call to zgetv0. -c -c INITV Logical variable. (INPUT) -c .TRUE. => the initial residual vector is given in RESID. -c .FALSE. => generate a random initial residual vector. -c -c N Integer. (INPUT) -c Dimension of the problem. -c -c J Integer. (INPUT) -c Index of the residual vector to be generated, with respect to -c the Arnoldi process. J > 1 in case of a "restart". -c -c V Complex*16 N by J array. (INPUT) -c The first J-1 columns of V contain the current Arnoldi basis -c if this is a "restart". -c -c LDV Integer. (INPUT) -c Leading dimension of V exactly as declared in the calling -c program. -c -c RESID Complex*16 array of length N. (INPUT/OUTPUT) -c Initial residual vector to be generated. If RESID is -c provided, force RESID into the range of the operator OP. -c -c RNORM Double precision scalar. (OUTPUT) -c B-norm of the generated residual. -c -c IPNTR Integer array of length 3. (OUTPUT) -c -c WORKD Complex*16 work array of length 2*N. (REVERSE COMMUNICATION). -c On exit, WORK(1:N) = B*RESID to be used in SSAITR. -c -c IERR Integer. (OUTPUT) -c = 0: Normal exit. -c = -1: Cannot generate a nontrivial restarted residual vector -c in the range of the operator OP. -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Local variables: -c xxxxxx Complex*16 -c -c\References: -c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in -c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), -c pp 357-385. -c -c\Routines called: -c arscnd ARPACK utility routine for timing. -c zvout ARPACK utility routine that prints vectors. -c zlarnv LAPACK routine for generating a random vector. -c zgemv Level 2 BLAS routine for matrix vector multiplication. -c zcopy Level 1 BLAS that copies one vector to another. -c zdotc Level 1 BLAS that computes the scalar product of two vectors. -c dznrm2 Level 1 BLAS that computes the norm of a vector. -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\SCCS Information: @(#) -c FILE: getv0.F SID: 2.3 DATE OF SID: 08/27/96 RELEASE: 2 -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine zgetv0 - & ( ido, bmat, itry, initv, n, j, v, ldv, resid, rnorm, - & ipntr, workd, ierr ) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - character bmat*1 - logical initv - integer ido, ierr, itry, j, ldv, n - Double precision - & rnorm -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - integer ipntr(3) - Complex*16 - & resid(n), v(ldv,j), workd(2*n) -c -c %------------% -c | Parameters | -c %------------% -c - Complex*16 - & one, zero - Double precision - & rzero - parameter (one = (1.0D+0, 0.0D+0), zero = (0.0D+0, 0.0D+0), - & rzero = 0.0D+0) -c -c %------------------------% -c | Local Scalars & Arrays | -c %------------------------% -c - logical first, inits, orth - integer idist, iseed(4), iter, msglvl, jj - Double precision - & rnorm0 - Complex*16 - & cnorm - save first, iseed, inits, iter, msglvl, orth, rnorm0 -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external zcopy, zgemv, zlarnv, zvout, arscnd -c -c %--------------------% -c | External Functions | -c %--------------------% -c - Double precision - & dznrm2, dlapy2 - Complex*16 - & zdotc - external zdotc, dznrm2, dlapy2 -c -c %-----------------% -c | Data Statements | -c %-----------------% -c - data inits /.true./ -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c -c -c %-----------------------------------% -c | Initialize the seed of the LAPACK | -c | random number generator | -c %-----------------------------------% -c - if (inits) then - iseed(1) = 1 - iseed(2) = 3 - iseed(3) = 5 - iseed(4) = 7 - inits = .false. - end if -c - if (ido .eq. 0) then -c -c %-------------------------------% -c | Initialize timing statistics | -c | & message level for debugging | -c %-------------------------------% -c - call arscnd (t0) - msglvl = mgetv0 -c - ierr = 0 - iter = 0 - first = .FALSE. - orth = .FALSE. -c -c %-----------------------------------------------------% -c | Possibly generate a random starting vector in RESID | -c | Use a LAPACK random number generator used by the | -c | matrix generation routines. | -c | idist = 1: uniform (0,1) distribution; | -c | idist = 2: uniform (-1,1) distribution; | -c | idist = 3: normal (0,1) distribution; | -c %-----------------------------------------------------% -c - if (.not.initv) then - idist = 2 - call zlarnv (idist, iseed, n, resid) - end if -c -c %----------------------------------------------------------% -c | Force the starting vector into the range of OP to handle | -c | the generalized problem when B is possibly (singular). | -c %----------------------------------------------------------% -c - call arscnd (t2) - if (bmat .eq. 'G') then - nopx = nopx + 1 - ipntr(1) = 1 - ipntr(2) = n + 1 - call zcopy (n, resid, 1, workd, 1) - ido = -1 - go to 9000 - end if - end if -c -c %----------------------------------------% -c | Back from computing B*(initial-vector) | -c %----------------------------------------% -c - if (first) go to 20 -c -c %-----------------------------------------------% -c | Back from computing B*(orthogonalized-vector) | -c %-----------------------------------------------% -c - if (orth) go to 40 -c - call arscnd (t3) - tmvopx = tmvopx + (t3 - t2) -c -c %------------------------------------------------------% -c | Starting vector is now in the range of OP; r = OP*r; | -c | Compute B-norm of starting vector. | -c %------------------------------------------------------% -c - call arscnd (t2) - first = .TRUE. - if (bmat .eq. 'G') then - nbx = nbx + 1 - call zcopy (n, workd(n+1), 1, resid, 1) - ipntr(1) = n + 1 - ipntr(2) = 1 - ido = 2 - go to 9000 - else if (bmat .eq. 'I') then - call zcopy (n, resid, 1, workd, 1) - end if -c - 20 continue -c - if (bmat .eq. 'G') then - call arscnd (t3) - tmvbx = tmvbx + (t3 - t2) - end if -c - first = .FALSE. - if (bmat .eq. 'G') then - cnorm = zdotc (n, resid, 1, workd, 1) - rnorm0 = sqrt(dlapy2(dble(cnorm),dimag(cnorm))) - else if (bmat .eq. 'I') then - rnorm0 = dznrm2(n, resid, 1) - end if - rnorm = rnorm0 -c -c %---------------------------------------------% -c | Exit if this is the very first Arnoldi step | -c %---------------------------------------------% -c - if (j .eq. 1) go to 50 -c -c %---------------------------------------------------------------- -c | Otherwise need to B-orthogonalize the starting vector against | -c | the current Arnoldi basis using Gram-Schmidt with iter. ref. | -c | This is the case where an invariant subspace is encountered | -c | in the middle of the Arnoldi factorization. | -c | | -c | s = V^{T}*B*r; r = r - V*s; | -c | | -c | Stopping criteria used for iter. ref. is discussed in | -c | Parlett's book, page 107 and in Gragg & Reichel TOMS paper. | -c %---------------------------------------------------------------% -c - orth = .TRUE. - 30 continue -c - call zgemv ('C', n, j-1, one, v, ldv, workd, 1, - & zero, workd(n+1), 1) - call zgemv ('N', n, j-1, -one, v, ldv, workd(n+1), 1, - & one, resid, 1) -c -c %----------------------------------------------------------% -c | Compute the B-norm of the orthogonalized starting vector | -c %----------------------------------------------------------% -c - call arscnd (t2) - if (bmat .eq. 'G') then - nbx = nbx + 1 - call zcopy (n, resid, 1, workd(n+1), 1) - ipntr(1) = n + 1 - ipntr(2) = 1 - ido = 2 - go to 9000 - else if (bmat .eq. 'I') then - call zcopy (n, resid, 1, workd, 1) - end if -c - 40 continue -c - if (bmat .eq. 'G') then - call arscnd (t3) - tmvbx = tmvbx + (t3 - t2) - end if -c - if (bmat .eq. 'G') then - cnorm = zdotc (n, resid, 1, workd, 1) - rnorm = sqrt(dlapy2(dble(cnorm),dimag(cnorm))) - else if (bmat .eq. 'I') then - rnorm = dznrm2(n, resid, 1) - end if -c -c %--------------------------------------% -c | Check for further orthogonalization. | -c %--------------------------------------% -c - if (msglvl .gt. 2) then - call dvout (logfil, 1, rnorm0, ndigit, - & '_getv0: re-orthonalization ; rnorm0 is') - call dvout (logfil, 1, rnorm, ndigit, - & '_getv0: re-orthonalization ; rnorm is') - end if -c - if (rnorm .gt. 0.717*rnorm0) go to 50 -c - iter = iter + 1 - if (iter .le. 1) then -c -c %-----------------------------------% -c | Perform iterative refinement step | -c %-----------------------------------% -c - rnorm0 = rnorm - go to 30 - else -c -c %------------------------------------% -c | Iterative refinement step "failed" | -c %------------------------------------% -c - do 45 jj = 1, n - resid(jj) = zero - 45 continue - rnorm = rzero - ierr = -1 - end if -c - 50 continue -c - if (msglvl .gt. 0) then - call dvout (logfil, 1, rnorm, ndigit, - & '_getv0: B-norm of initial / restarted starting vector') - end if - if (msglvl .gt. 2) then - call zvout (logfil, n, resid, ndigit, - & '_getv0: initial / restarted starting vector') - end if - ido = 99 -c - call arscnd (t1) - tgetv0 = tgetv0 + (t1 - t0) -c - 9000 continue - return -c -c %---------------% -c | End of zgetv0 | -c %---------------% -c - end
--- a/libcruft/arpack/src/znaitr.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,850 +0,0 @@ -c\BeginDoc -c -c\Name: znaitr -c -c\Description: -c Reverse communication interface for applying NP additional steps to -c a K step nonsymmetric Arnoldi factorization. -c -c Input: OP*V_{k} - V_{k}*H = r_{k}*e_{k}^T -c -c with (V_{k}^T)*B*V_{k} = I, (V_{k}^T)*B*r_{k} = 0. -c -c Output: OP*V_{k+p} - V_{k+p}*H = r_{k+p}*e_{k+p}^T -c -c with (V_{k+p}^T)*B*V_{k+p} = I, (V_{k+p}^T)*B*r_{k+p} = 0. -c -c where OP and B are as in znaupd. The B-norm of r_{k+p} is also -c computed and returned. -c -c\Usage: -c call znaitr -c ( IDO, BMAT, N, K, NP, NB, RESID, RNORM, V, LDV, H, LDH, -c IPNTR, WORKD, INFO ) -c -c\Arguments -c IDO Integer. (INPUT/OUTPUT) -c Reverse communication flag. -c ------------------------------------------------------------- -c IDO = 0: first call to the reverse communication interface -c IDO = -1: compute Y = OP * X where -c IPNTR(1) is the pointer into WORK for X, -c IPNTR(2) is the pointer into WORK for Y. -c This is for the restart phase to force the new -c starting vector into the range of OP. -c IDO = 1: compute Y = OP * X where -c IPNTR(1) is the pointer into WORK for X, -c IPNTR(2) is the pointer into WORK for Y, -c IPNTR(3) is the pointer into WORK for B * X. -c IDO = 2: compute Y = B * X where -c IPNTR(1) is the pointer into WORK for X, -c IPNTR(2) is the pointer into WORK for Y. -c IDO = 99: done -c ------------------------------------------------------------- -c When the routine is used in the "shift-and-invert" mode, the -c vector B * Q is already available and do not need to be -c recomputed in forming OP * Q. -c -c BMAT Character*1. (INPUT) -c BMAT specifies the type of the matrix B that defines the -c semi-inner product for the operator OP. See znaupd. -c B = 'I' -> standard eigenvalue problem A*x = lambda*x -c B = 'G' -> generalized eigenvalue problem A*x = lambda*M**x -c -c N Integer. (INPUT) -c Dimension of the eigenproblem. -c -c K Integer. (INPUT) -c Current size of V and H. -c -c NP Integer. (INPUT) -c Number of additional Arnoldi steps to take. -c -c NB Integer. (INPUT) -c Blocksize to be used in the recurrence. -c Only work for NB = 1 right now. The goal is to have a -c program that implement both the block and non-block method. -c -c RESID Complex*16 array of length N. (INPUT/OUTPUT) -c On INPUT: RESID contains the residual vector r_{k}. -c On OUTPUT: RESID contains the residual vector r_{k+p}. -c -c RNORM Double precision scalar. (INPUT/OUTPUT) -c B-norm of the starting residual on input. -c B-norm of the updated residual r_{k+p} on output. -c -c V Complex*16 N by K+NP array. (INPUT/OUTPUT) -c On INPUT: V contains the Arnoldi vectors in the first K -c columns. -c On OUTPUT: V contains the new NP Arnoldi vectors in the next -c NP columns. The first K columns are unchanged. -c -c LDV Integer. (INPUT) -c Leading dimension of V exactly as declared in the calling -c program. -c -c H Complex*16 (K+NP) by (K+NP) array. (INPUT/OUTPUT) -c H is used to store the generated upper Hessenberg matrix. -c -c LDH Integer. (INPUT) -c Leading dimension of H exactly as declared in the calling -c program. -c -c IPNTR Integer array of length 3. (OUTPUT) -c Pointer to mark the starting locations in the WORK for -c vectors used by the Arnoldi iteration. -c ------------------------------------------------------------- -c IPNTR(1): pointer to the current operand vector X. -c IPNTR(2): pointer to the current result vector Y. -c IPNTR(3): pointer to the vector B * X when used in the -c shift-and-invert mode. X is the current operand. -c ------------------------------------------------------------- -c -c WORKD Complex*16 work array of length 3*N. (REVERSE COMMUNICATION) -c Distributed array to be used in the basic Arnoldi iteration -c for reverse communication. The calling program should not -c use WORKD as temporary workspace during the iteration !!!!!! -c On input, WORKD(1:N) = B*RESID and is used to save some -c computation at the first step. -c -c INFO Integer. (OUTPUT) -c = 0: Normal exit. -c > 0: Size of the spanning invariant subspace of OP found. -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Local variables: -c xxxxxx Complex*16 -c -c\References: -c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in -c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), -c pp 357-385. -c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly -c Restarted Arnoldi Iteration", Rice University Technical Report -c TR95-13, Department of Computational and Applied Mathematics. -c -c\Routines called: -c zgetv0 ARPACK routine to generate the initial vector. -c ivout ARPACK utility routine that prints integers. -c arscnd ARPACK utility routine for timing. -c zmout ARPACK utility routine that prints matrices -c zvout ARPACK utility routine that prints vectors. -c zlanhs LAPACK routine that computes various norms of a matrix. -c zlascl LAPACK routine for careful scaling of a matrix. -c dlabad LAPACK routine for defining the underflow and overflow -c limits. -c dlamch LAPACK routine that determines machine constants. -c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. -c zgemv Level 2 BLAS routine for matrix vector multiplication. -c zaxpy Level 1 BLAS that computes a vector triad. -c zcopy Level 1 BLAS that copies one vector to another . -c zdotc Level 1 BLAS that computes the scalar product of two vectors. -c zscal Level 1 BLAS that scales a vector. -c zdscal Level 1 BLAS that scales a complex vector by a real number. -c dznrm2 Level 1 BLAS that computes the norm of a vector. -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\SCCS Information: @(#) -c FILE: naitr.F SID: 2.3 DATE OF SID: 8/27/96 RELEASE: 2 -c -c\Remarks -c The algorithm implemented is: -c -c restart = .false. -c Given V_{k} = [v_{1}, ..., v_{k}], r_{k}; -c r_{k} contains the initial residual vector even for k = 0; -c Also assume that rnorm = || B*r_{k} || and B*r_{k} are already -c computed by the calling program. -c -c betaj = rnorm ; p_{k+1} = B*r_{k} ; -c For j = k+1, ..., k+np Do -c 1) if ( betaj < tol ) stop or restart depending on j. -c ( At present tol is zero ) -c if ( restart ) generate a new starting vector. -c 2) v_{j} = r(j-1)/betaj; V_{j} = [V_{j-1}, v_{j}]; -c p_{j} = p_{j}/betaj -c 3) r_{j} = OP*v_{j} where OP is defined as in znaupd -c For shift-invert mode p_{j} = B*v_{j} is already available. -c wnorm = || OP*v_{j} || -c 4) Compute the j-th step residual vector. -c w_{j} = V_{j}^T * B * OP * v_{j} -c r_{j} = OP*v_{j} - V_{j} * w_{j} -c H(:,j) = w_{j}; -c H(j,j-1) = rnorm -c rnorm = || r_(j) || -c If (rnorm > 0.717*wnorm) accept step and go back to 1) -c 5) Re-orthogonalization step: -c s = V_{j}'*B*r_{j} -c r_{j} = r_{j} - V_{j}*s; rnorm1 = || r_{j} || -c alphaj = alphaj + s_{j}; -c 6) Iterative refinement step: -c If (rnorm1 > 0.717*rnorm) then -c rnorm = rnorm1 -c accept step and go back to 1) -c Else -c rnorm = rnorm1 -c If this is the first time in step 6), go to 5) -c Else r_{j} lies in the span of V_{j} numerically. -c Set r_{j} = 0 and rnorm = 0; go to 1) -c EndIf -c End Do -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine znaitr - & (ido, bmat, n, k, np, nb, resid, rnorm, v, ldv, h, ldh, - & ipntr, workd, info) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - character bmat*1 - integer ido, info, k, ldh, ldv, n, nb, np - Double precision - & rnorm -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - integer ipntr(3) - Complex*16 - & h(ldh,k+np), resid(n), v(ldv,k+np), workd(3*n) -c -c %------------% -c | Parameters | -c %------------% -c - Complex*16 - & one, zero - Double precision - & rone, rzero - parameter (one = (1.0D+0, 0.0D+0), zero = (0.0D+0, 0.0D+0), - & rone = 1.0D+0, rzero = 0.0D+0) -c -c %--------------% -c | Local Arrays | -c %--------------% -c - Double precision - & rtemp(2) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - logical first, orth1, orth2, rstart, step3, step4 - integer ierr, i, infol, ipj, irj, ivj, iter, itry, j, msglvl, - & jj - Double precision - & ovfl, smlnum, tst1, ulp, unfl, betaj, - & temp1, rnorm1, wnorm - Complex*16 - & cnorm -c - save first, orth1, orth2, rstart, step3, step4, - & ierr, ipj, irj, ivj, iter, itry, j, msglvl, ovfl, - & betaj, rnorm1, smlnum, ulp, unfl, wnorm -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external zaxpy, zcopy, zscal, zdscal, zgemv, zgetv0, - & dlabad, zvout, zmout, ivout, arscnd -c -c %--------------------% -c | External Functions | -c %--------------------% -c - Complex*16 - & zdotc - Double precision - & dlamch, dznrm2, zlanhs, dlapy2 - external zdotc, dznrm2, zlanhs, dlamch, dlapy2 -c -c %---------------------% -c | Intrinsic Functions | -c %---------------------% -c - intrinsic dimag, dble, max, sqrt -c -c %-----------------% -c | Data statements | -c %-----------------% -c - data first / .true. / -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c - if (first) then -c -c %-----------------------------------------% -c | Set machine-dependent constants for the | -c | the splitting and deflation criterion. | -c | If norm(H) <= sqrt(OVFL), | -c | overflow should not occur. | -c | REFERENCE: LAPACK subroutine zlahqr | -c %-----------------------------------------% -c - unfl = dlamch( 'safe minimum' ) - ovfl = dble(one / unfl) - call dlabad( unfl, ovfl ) - ulp = dlamch( 'precision' ) - smlnum = unfl*( n / ulp ) - first = .false. - end if -c - if (ido .eq. 0) then -c -c %-------------------------------% -c | Initialize timing statistics | -c | & message level for debugging | -c %-------------------------------% -c - call arscnd (t0) - msglvl = mcaitr -c -c %------------------------------% -c | Initial call to this routine | -c %------------------------------% -c - info = 0 - step3 = .false. - step4 = .false. - rstart = .false. - orth1 = .false. - orth2 = .false. - j = k + 1 - ipj = 1 - irj = ipj + n - ivj = irj + n - end if -c -c %-------------------------------------------------% -c | When in reverse communication mode one of: | -c | STEP3, STEP4, ORTH1, ORTH2, RSTART | -c | will be .true. when .... | -c | STEP3: return from computing OP*v_{j}. | -c | STEP4: return from computing B-norm of OP*v_{j} | -c | ORTH1: return from computing B-norm of r_{j+1} | -c | ORTH2: return from computing B-norm of | -c | correction to the residual vector. | -c | RSTART: return from OP computations needed by | -c | zgetv0. | -c %-------------------------------------------------% -c - if (step3) go to 50 - if (step4) go to 60 - if (orth1) go to 70 - if (orth2) go to 90 - if (rstart) go to 30 -c -c %-----------------------------% -c | Else this is the first step | -c %-----------------------------% -c -c %--------------------------------------------------------------% -c | | -c | A R N O L D I I T E R A T I O N L O O P | -c | | -c | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) | -c %--------------------------------------------------------------% - - 1000 continue -c - if (msglvl .gt. 1) then - call ivout (logfil, 1, j, ndigit, - & '_naitr: generating Arnoldi vector number') - call dvout (logfil, 1, rnorm, ndigit, - & '_naitr: B-norm of the current residual is') - end if -c -c %---------------------------------------------------% -c | STEP 1: Check if the B norm of j-th residual | -c | vector is zero. Equivalent to determine whether | -c | an exact j-step Arnoldi factorization is present. | -c %---------------------------------------------------% -c - betaj = rnorm - if (rnorm .gt. rzero) go to 40 -c -c %---------------------------------------------------% -c | Invariant subspace found, generate a new starting | -c | vector which is orthogonal to the current Arnoldi | -c | basis and continue the iteration. | -c %---------------------------------------------------% -c - if (msglvl .gt. 0) then - call ivout (logfil, 1, j, ndigit, - & '_naitr: ****** RESTART AT STEP ******') - end if -c -c %---------------------------------------------% -c | ITRY is the loop variable that controls the | -c | maximum amount of times that a restart is | -c | attempted. NRSTRT is used by stat.h | -c %---------------------------------------------% -c - betaj = rzero - nrstrt = nrstrt + 1 - itry = 1 - 20 continue - rstart = .true. - ido = 0 - 30 continue -c -c %--------------------------------------% -c | If in reverse communication mode and | -c | RSTART = .true. flow returns here. | -c %--------------------------------------% -c - call zgetv0 (ido, bmat, itry, .false., n, j, v, ldv, - & resid, rnorm, ipntr, workd, ierr) - if (ido .ne. 99) go to 9000 - if (ierr .lt. 0) then - itry = itry + 1 - if (itry .le. 3) go to 20 -c -c %------------------------------------------------% -c | Give up after several restart attempts. | -c | Set INFO to the size of the invariant subspace | -c | which spans OP and exit. | -c %------------------------------------------------% -c - info = j - 1 - call arscnd (t1) - tcaitr = tcaitr + (t1 - t0) - ido = 99 - go to 9000 - end if -c - 40 continue -c -c %---------------------------------------------------------% -c | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm | -c | Note that p_{j} = B*r_{j-1}. In order to avoid overflow | -c | when reciprocating a small RNORM, test against lower | -c | machine bound. | -c %---------------------------------------------------------% -c - call zcopy (n, resid, 1, v(1,j), 1) - if ( rnorm .ge. unfl) then - temp1 = rone / rnorm - call zdscal (n, temp1, v(1,j), 1) - call zdscal (n, temp1, workd(ipj), 1) - else -c -c %-----------------------------------------% -c | To scale both v_{j} and p_{j} carefully | -c | use LAPACK routine zlascl | -c %-----------------------------------------% -c - call zlascl ('General', i, i, rnorm, rone, - & n, 1, v(1,j), n, infol) - call zlascl ('General', i, i, rnorm, rone, - & n, 1, workd(ipj), n, infol) - end if -c -c %------------------------------------------------------% -c | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} | -c | Note that this is not quite yet r_{j}. See STEP 4 | -c %------------------------------------------------------% -c - step3 = .true. - nopx = nopx + 1 - call arscnd (t2) - call zcopy (n, v(1,j), 1, workd(ivj), 1) - ipntr(1) = ivj - ipntr(2) = irj - ipntr(3) = ipj - ido = 1 -c -c %-----------------------------------% -c | Exit in order to compute OP*v_{j} | -c %-----------------------------------% -c - go to 9000 - 50 continue -c -c %----------------------------------% -c | Back from reverse communication; | -c | WORKD(IRJ:IRJ+N-1) := OP*v_{j} | -c | if step3 = .true. | -c %----------------------------------% -c - call arscnd (t3) - tmvopx = tmvopx + (t3 - t2) - - step3 = .false. -c -c %------------------------------------------% -c | Put another copy of OP*v_{j} into RESID. | -c %------------------------------------------% -c - call zcopy (n, workd(irj), 1, resid, 1) -c -c %---------------------------------------% -c | STEP 4: Finish extending the Arnoldi | -c | factorization to length j. | -c %---------------------------------------% -c - call arscnd (t2) - if (bmat .eq. 'G') then - nbx = nbx + 1 - step4 = .true. - ipntr(1) = irj - ipntr(2) = ipj - ido = 2 -c -c %-------------------------------------% -c | Exit in order to compute B*OP*v_{j} | -c %-------------------------------------% -c - go to 9000 - else if (bmat .eq. 'I') then - call zcopy (n, resid, 1, workd(ipj), 1) - end if - 60 continue -c -c %----------------------------------% -c | Back from reverse communication; | -c | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j} | -c | if step4 = .true. | -c %----------------------------------% -c - if (bmat .eq. 'G') then - call arscnd (t3) - tmvbx = tmvbx + (t3 - t2) - end if -c - step4 = .false. -c -c %-------------------------------------% -c | The following is needed for STEP 5. | -c | Compute the B-norm of OP*v_{j}. | -c %-------------------------------------% -c - if (bmat .eq. 'G') then - cnorm = zdotc (n, resid, 1, workd(ipj), 1) - wnorm = sqrt( dlapy2(dble(cnorm),dimag(cnorm)) ) - else if (bmat .eq. 'I') then - wnorm = dznrm2(n, resid, 1) - end if -c -c %-----------------------------------------% -c | Compute the j-th residual corresponding | -c | to the j step factorization. | -c | Use Classical Gram Schmidt and compute: | -c | w_{j} <- V_{j}^T * B * OP * v_{j} | -c | r_{j} <- OP*v_{j} - V_{j} * w_{j} | -c %-----------------------------------------% -c -c -c %------------------------------------------% -c | Compute the j Fourier coefficients w_{j} | -c | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. | -c %------------------------------------------% -c - call zgemv ('C', n, j, one, v, ldv, workd(ipj), 1, - & zero, h(1,j), 1) -c -c %--------------------------------------% -c | Orthogonalize r_{j} against V_{j}. | -c | RESID contains OP*v_{j}. See STEP 3. | -c %--------------------------------------% -c - call zgemv ('N', n, j, -one, v, ldv, h(1,j), 1, - & one, resid, 1) -c - if (j .gt. 1) h(j,j-1) = dcmplx(betaj, rzero) -c - call arscnd (t4) -c - orth1 = .true. -c - call arscnd (t2) - if (bmat .eq. 'G') then - nbx = nbx + 1 - call zcopy (n, resid, 1, workd(irj), 1) - ipntr(1) = irj - ipntr(2) = ipj - ido = 2 -c -c %----------------------------------% -c | Exit in order to compute B*r_{j} | -c %----------------------------------% -c - go to 9000 - else if (bmat .eq. 'I') then - call zcopy (n, resid, 1, workd(ipj), 1) - end if - 70 continue -c -c %---------------------------------------------------% -c | Back from reverse communication if ORTH1 = .true. | -c | WORKD(IPJ:IPJ+N-1) := B*r_{j}. | -c %---------------------------------------------------% -c - if (bmat .eq. 'G') then - call arscnd (t3) - tmvbx = tmvbx + (t3 - t2) - end if -c - orth1 = .false. -c -c %------------------------------% -c | Compute the B-norm of r_{j}. | -c %------------------------------% -c - if (bmat .eq. 'G') then - cnorm = zdotc (n, resid, 1, workd(ipj), 1) - rnorm = sqrt( dlapy2(dble(cnorm),dimag(cnorm)) ) - else if (bmat .eq. 'I') then - rnorm = dznrm2(n, resid, 1) - end if -c -c %-----------------------------------------------------------% -c | STEP 5: Re-orthogonalization / Iterative refinement phase | -c | Maximum NITER_ITREF tries. | -c | | -c | s = V_{j}^T * B * r_{j} | -c | r_{j} = r_{j} - V_{j}*s | -c | alphaj = alphaj + s_{j} | -c | | -c | The stopping criteria used for iterative refinement is | -c | discussed in Parlett's book SEP, page 107 and in Gragg & | -c | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. | -c | Determine if we need to correct the residual. The goal is | -c | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || | -c | The following test determines whether the sine of the | -c | angle between OP*x and the computed residual is less | -c | than or equal to 0.717. | -c %-----------------------------------------------------------% -c - if ( rnorm .gt. 0.717*wnorm ) go to 100 -c - iter = 0 - nrorth = nrorth + 1 -c -c %---------------------------------------------------% -c | Enter the Iterative refinement phase. If further | -c | refinement is necessary, loop back here. The loop | -c | variable is ITER. Perform a step of Classical | -c | Gram-Schmidt using all the Arnoldi vectors V_{j} | -c %---------------------------------------------------% -c - 80 continue -c - if (msglvl .gt. 2) then - rtemp(1) = wnorm - rtemp(2) = rnorm - call dvout (logfil, 2, rtemp, ndigit, - & '_naitr: re-orthogonalization; wnorm and rnorm are') - call zvout (logfil, j, h(1,j), ndigit, - & '_naitr: j-th column of H') - end if -c -c %----------------------------------------------------% -c | Compute V_{j}^T * B * r_{j}. | -c | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). | -c %----------------------------------------------------% -c - call zgemv ('C', n, j, one, v, ldv, workd(ipj), 1, - & zero, workd(irj), 1) -c -c %---------------------------------------------% -c | Compute the correction to the residual: | -c | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). | -c | The correction to H is v(:,1:J)*H(1:J,1:J) | -c | + v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j. | -c %---------------------------------------------% -c - call zgemv ('N', n, j, -one, v, ldv, workd(irj), 1, - & one, resid, 1) - call zaxpy (j, one, workd(irj), 1, h(1,j), 1) -c - orth2 = .true. - call arscnd (t2) - if (bmat .eq. 'G') then - nbx = nbx + 1 - call zcopy (n, resid, 1, workd(irj), 1) - ipntr(1) = irj - ipntr(2) = ipj - ido = 2 -c -c %-----------------------------------% -c | Exit in order to compute B*r_{j}. | -c | r_{j} is the corrected residual. | -c %-----------------------------------% -c - go to 9000 - else if (bmat .eq. 'I') then - call zcopy (n, resid, 1, workd(ipj), 1) - end if - 90 continue -c -c %---------------------------------------------------% -c | Back from reverse communication if ORTH2 = .true. | -c %---------------------------------------------------% -c - if (bmat .eq. 'G') then - call arscnd (t3) - tmvbx = tmvbx + (t3 - t2) - end if -c -c %-----------------------------------------------------% -c | Compute the B-norm of the corrected residual r_{j}. | -c %-----------------------------------------------------% -c - if (bmat .eq. 'G') then - cnorm = zdotc (n, resid, 1, workd(ipj), 1) - rnorm1 = sqrt( dlapy2(dble(cnorm),dimag(cnorm)) ) - else if (bmat .eq. 'I') then - rnorm1 = dznrm2(n, resid, 1) - end if -c - if (msglvl .gt. 0 .and. iter .gt. 0 ) then - call ivout (logfil, 1, j, ndigit, - & '_naitr: Iterative refinement for Arnoldi residual') - if (msglvl .gt. 2) then - rtemp(1) = rnorm - rtemp(2) = rnorm1 - call dvout (logfil, 2, rtemp, ndigit, - & '_naitr: iterative refinement ; rnorm and rnorm1 are') - end if - end if -c -c %-----------------------------------------% -c | Determine if we need to perform another | -c | step of re-orthogonalization. | -c %-----------------------------------------% -c - if ( rnorm1 .gt. 0.717*rnorm ) then -c -c %---------------------------------------% -c | No need for further refinement. | -c | The cosine of the angle between the | -c | corrected residual vector and the old | -c | residual vector is greater than 0.717 | -c | In other words the corrected residual | -c | and the old residual vector share an | -c | angle of less than arcCOS(0.717) | -c %---------------------------------------% -c - rnorm = rnorm1 -c - else -c -c %-------------------------------------------% -c | Another step of iterative refinement step | -c | is required. NITREF is used by stat.h | -c %-------------------------------------------% -c - nitref = nitref + 1 - rnorm = rnorm1 - iter = iter + 1 - if (iter .le. 1) go to 80 -c -c %-------------------------------------------------% -c | Otherwise RESID is numerically in the span of V | -c %-------------------------------------------------% -c - do 95 jj = 1, n - resid(jj) = zero - 95 continue - rnorm = rzero - end if -c -c %----------------------------------------------% -c | Branch here directly if iterative refinement | -c | wasn't necessary or after at most NITER_REF | -c | steps of iterative refinement. | -c %----------------------------------------------% -c - 100 continue -c - rstart = .false. - orth2 = .false. -c - call arscnd (t5) - titref = titref + (t5 - t4) -c -c %------------------------------------% -c | STEP 6: Update j = j+1; Continue | -c %------------------------------------% -c - j = j + 1 - if (j .gt. k+np) then - call arscnd (t1) - tcaitr = tcaitr + (t1 - t0) - ido = 99 - do 110 i = max(1,k), k+np-1 -c -c %--------------------------------------------% -c | Check for splitting and deflation. | -c | Use a standard test as in the QR algorithm | -c | REFERENCE: LAPACK subroutine zlahqr | -c %--------------------------------------------% -c - tst1 = dlapy2(dble(h(i,i)),dimag(h(i,i))) - & + dlapy2(dble(h(i+1,i+1)), dimag(h(i+1,i+1))) - if( tst1.eq.dble(zero) ) - & tst1 = zlanhs( '1', k+np, h, ldh, workd(n+1) ) - if( dlapy2(dble(h(i+1,i)),dimag(h(i+1,i))) .le. - & max( ulp*tst1, smlnum ) ) - & h(i+1,i) = zero - 110 continue -c - if (msglvl .gt. 2) then - call zmout (logfil, k+np, k+np, h, ldh, ndigit, - & '_naitr: Final upper Hessenberg matrix H of order K+NP') - end if -c - go to 9000 - end if -c -c %--------------------------------------------------------% -c | Loop back to extend the factorization by another step. | -c %--------------------------------------------------------% -c - go to 1000 -c -c %---------------------------------------------------------------% -c | | -c | E N D O F M A I N I T E R A T I O N L O O P | -c | | -c %---------------------------------------------------------------% -c - 9000 continue - return -c -c %---------------% -c | End of znaitr | -c %---------------% -c - end
--- a/libcruft/arpack/src/znapps.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,507 +0,0 @@ -c\BeginDoc -c -c\Name: znapps -c -c\Description: -c Given the Arnoldi factorization -c -c A*V_{k} - V_{k}*H_{k} = r_{k+p}*e_{k+p}^T, -c -c apply NP implicit shifts resulting in -c -c A*(V_{k}*Q) - (V_{k}*Q)*(Q^T* H_{k}*Q) = r_{k+p}*e_{k+p}^T * Q -c -c where Q is an orthogonal matrix which is the product of rotations -c and reflections resulting from the NP bulge change sweeps. -c The updated Arnoldi factorization becomes: -c -c A*VNEW_{k} - VNEW_{k}*HNEW_{k} = rnew_{k}*e_{k}^T. -c -c\Usage: -c call znapps -c ( N, KEV, NP, SHIFT, V, LDV, H, LDH, RESID, Q, LDQ, -c WORKL, WORKD ) -c -c\Arguments -c N Integer. (INPUT) -c Problem size, i.e. size of matrix A. -c -c KEV Integer. (INPUT/OUTPUT) -c KEV+NP is the size of the input matrix H. -c KEV is the size of the updated matrix HNEW. -c -c NP Integer. (INPUT) -c Number of implicit shifts to be applied. -c -c SHIFT Complex*16 array of length NP. (INPUT) -c The shifts to be applied. -c -c V Complex*16 N by (KEV+NP) array. (INPUT/OUTPUT) -c On INPUT, V contains the current KEV+NP Arnoldi vectors. -c On OUTPUT, V contains the updated KEV Arnoldi vectors -c in the first KEV columns of V. -c -c LDV Integer. (INPUT) -c Leading dimension of V exactly as declared in the calling -c program. -c -c H Complex*16 (KEV+NP) by (KEV+NP) array. (INPUT/OUTPUT) -c On INPUT, H contains the current KEV+NP by KEV+NP upper -c Hessenberg matrix of the Arnoldi factorization. -c On OUTPUT, H contains the updated KEV by KEV upper Hessenberg -c matrix in the KEV leading submatrix. -c -c LDH Integer. (INPUT) -c Leading dimension of H exactly as declared in the calling -c program. -c -c RESID Complex*16 array of length N. (INPUT/OUTPUT) -c On INPUT, RESID contains the the residual vector r_{k+p}. -c On OUTPUT, RESID is the update residual vector rnew_{k} -c in the first KEV locations. -c -c Q Complex*16 KEV+NP by KEV+NP work array. (WORKSPACE) -c Work array used to accumulate the rotations and reflections -c during the bulge chase sweep. -c -c LDQ Integer. (INPUT) -c Leading dimension of Q exactly as declared in the calling -c program. -c -c WORKL Complex*16 work array of length (KEV+NP). (WORKSPACE) -c Private (replicated) array on each PE or array allocated on -c the front end. -c -c WORKD Complex*16 work array of length 2*N. (WORKSPACE) -c Distributed array used in the application of the accumulated -c orthogonal matrix Q. -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Local variables: -c xxxxxx Complex*16 -c -c\References: -c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in -c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), -c pp 357-385. -c -c\Routines called: -c ivout ARPACK utility routine that prints integers. -c arscnd ARPACK utility routine for timing. -c zmout ARPACK utility routine that prints matrices -c zvout ARPACK utility routine that prints vectors. -c zlacpy LAPACK matrix copy routine. -c zlanhs LAPACK routine that computes various norms of a matrix. -c zlartg LAPACK Givens rotation construction routine. -c zlaset LAPACK matrix initialization routine. -c dlabad LAPACK routine for defining the underflow and overflow -c limits. -c dlamch LAPACK routine that determines machine constants. -c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. -c zgemv Level 2 BLAS routine for matrix vector multiplication. -c zaxpy Level 1 BLAS that computes a vector triad. -c zcopy Level 1 BLAS that copies one vector to another. -c zscal Level 1 BLAS that scales a vector. -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\SCCS Information: @(#) -c FILE: napps.F SID: 2.3 DATE OF SID: 3/28/97 RELEASE: 2 -c -c\Remarks -c 1. In this version, each shift is applied to all the sublocks of -c the Hessenberg matrix H and not just to the submatrix that it -c comes from. Deflation as in LAPACK routine zlahqr (QR algorithm -c for upper Hessenberg matrices ) is used. -c Upon output, the subdiagonals of H are enforced to be non-negative -c real numbers. -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine znapps - & ( n, kev, np, shift, v, ldv, h, ldh, resid, q, ldq, - & workl, workd ) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - integer kev, ldh, ldq, ldv, n, np -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - Complex*16 - & h(ldh,kev+np), resid(n), shift(np), - & v(ldv,kev+np), q(ldq,kev+np), workd(2*n), workl(kev+np) -c -c %------------% -c | Parameters | -c %------------% -c - Complex*16 - & one, zero - Double precision - & rzero - parameter (one = (1.0D+0, 0.0D+0), zero = (0.0D+0, 0.0D+0), - & rzero = 0.0D+0) -c -c %------------------------% -c | Local Scalars & Arrays | -c %------------------------% -c - integer i, iend, istart, j, jj, kplusp, msglvl - logical first - Complex*16 - & cdum, f, g, h11, h21, r, s, sigma, t - Double precision - & c, ovfl, smlnum, ulp, unfl, tst1 - save first, ovfl, smlnum, ulp, unfl -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external zaxpy, zcopy, zgemv, zscal, zlacpy, zlartg, - & zvout, zlaset, dlabad, zmout, arscnd, ivout -c -c %--------------------% -c | External Functions | -c %--------------------% -c - Double precision - & zlanhs, dlamch, dlapy2 - external zlanhs, dlamch, dlapy2 -c -c %----------------------% -c | Intrinsics Functions | -c %----------------------% -c - intrinsic abs, dimag, conjg, dcmplx, max, min, dble -c -c %---------------------% -c | Statement Functions | -c %---------------------% -c - Double precision - & zabs1 - zabs1( cdum ) = abs( dble( cdum ) ) + abs( dimag( cdum ) ) -c -c %----------------% -c | Data statments | -c %----------------% -c - data first / .true. / -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c - if (first) then -c -c %-----------------------------------------------% -c | Set machine-dependent constants for the | -c | stopping criterion. If norm(H) <= sqrt(OVFL), | -c | overflow should not occur. | -c | REFERENCE: LAPACK subroutine zlahqr | -c %-----------------------------------------------% -c - unfl = dlamch( 'safe minimum' ) - ovfl = dble(one / unfl) - call dlabad( unfl, ovfl ) - ulp = dlamch( 'precision' ) - smlnum = unfl*( n / ulp ) - first = .false. - end if -c -c %-------------------------------% -c | Initialize timing statistics | -c | & message level for debugging | -c %-------------------------------% -c - call arscnd (t0) - msglvl = mcapps -c - kplusp = kev + np -c -c %--------------------------------------------% -c | Initialize Q to the identity to accumulate | -c | the rotations and reflections | -c %--------------------------------------------% -c - call zlaset ('All', kplusp, kplusp, zero, one, q, ldq) -c -c %----------------------------------------------% -c | Quick return if there are no shifts to apply | -c %----------------------------------------------% -c - if (np .eq. 0) go to 9000 -c -c %----------------------------------------------% -c | Chase the bulge with the application of each | -c | implicit shift. Each shift is applied to the | -c | whole matrix including each block. | -c %----------------------------------------------% -c - do 110 jj = 1, np - sigma = shift(jj) -c - if (msglvl .gt. 2 ) then - call ivout (logfil, 1, jj, ndigit, - & '_napps: shift number.') - call zvout (logfil, 1, sigma, ndigit, - & '_napps: Value of the shift ') - end if -c - istart = 1 - 20 continue -c - do 30 i = istart, kplusp-1 -c -c %----------------------------------------% -c | Check for splitting and deflation. Use | -c | a standard test as in the QR algorithm | -c | REFERENCE: LAPACK subroutine zlahqr | -c %----------------------------------------% -c - tst1 = zabs1( h( i, i ) ) + zabs1( h( i+1, i+1 ) ) - if( tst1.eq.rzero ) - & tst1 = zlanhs( '1', kplusp-jj+1, h, ldh, workl ) - if ( abs(dble(h(i+1,i))) - & .le. max(ulp*tst1, smlnum) ) then - if (msglvl .gt. 0) then - call ivout (logfil, 1, i, ndigit, - & '_napps: matrix splitting at row/column no.') - call ivout (logfil, 1, jj, ndigit, - & '_napps: matrix splitting with shift number.') - call zvout (logfil, 1, h(i+1,i), ndigit, - & '_napps: off diagonal element.') - end if - iend = i - h(i+1,i) = zero - go to 40 - end if - 30 continue - iend = kplusp - 40 continue -c - if (msglvl .gt. 2) then - call ivout (logfil, 1, istart, ndigit, - & '_napps: Start of current block ') - call ivout (logfil, 1, iend, ndigit, - & '_napps: End of current block ') - end if -c -c %------------------------------------------------% -c | No reason to apply a shift to block of order 1 | -c | or if the current block starts after the point | -c | of compression since we'll discard this stuff | -c %------------------------------------------------% -c - if ( istart .eq. iend .or. istart .gt. kev) go to 100 -c - h11 = h(istart,istart) - h21 = h(istart+1,istart) - f = h11 - sigma - g = h21 -c - do 80 i = istart, iend-1 -c -c %------------------------------------------------------% -c | Construct the plane rotation G to zero out the bulge | -c %------------------------------------------------------% -c - call zlartg (f, g, c, s, r) - if (i .gt. istart) then - h(i,i-1) = r - h(i+1,i-1) = zero - end if -c -c %---------------------------------------------% -c | Apply rotation to the left of H; H <- G'*H | -c %---------------------------------------------% -c - do 50 j = i, kplusp - t = c*h(i,j) + s*h(i+1,j) - h(i+1,j) = -conjg(s)*h(i,j) + c*h(i+1,j) - h(i,j) = t - 50 continue -c -c %---------------------------------------------% -c | Apply rotation to the right of H; H <- H*G | -c %---------------------------------------------% -c - do 60 j = 1, min(i+2,iend) - t = c*h(j,i) + conjg(s)*h(j,i+1) - h(j,i+1) = -s*h(j,i) + c*h(j,i+1) - h(j,i) = t - 60 continue -c -c %-----------------------------------------------------% -c | Accumulate the rotation in the matrix Q; Q <- Q*G' | -c %-----------------------------------------------------% -c - do 70 j = 1, min(i+jj, kplusp) - t = c*q(j,i) + conjg(s)*q(j,i+1) - q(j,i+1) = - s*q(j,i) + c*q(j,i+1) - q(j,i) = t - 70 continue -c -c %---------------------------% -c | Prepare for next rotation | -c %---------------------------% -c - if (i .lt. iend-1) then - f = h(i+1,i) - g = h(i+2,i) - end if - 80 continue -c -c %-------------------------------% -c | Finished applying the shift. | -c %-------------------------------% -c - 100 continue -c -c %---------------------------------------------------------% -c | Apply the same shift to the next block if there is any. | -c %---------------------------------------------------------% -c - istart = iend + 1 - if (iend .lt. kplusp) go to 20 -c -c %---------------------------------------------% -c | Loop back to the top to get the next shift. | -c %---------------------------------------------% -c - 110 continue -c -c %---------------------------------------------------% -c | Perform a similarity transformation that makes | -c | sure that the compressed H will have non-negative | -c | real subdiagonal elements. | -c %---------------------------------------------------% -c - do 120 j=1,kev - if ( dble( h(j+1,j) ) .lt. rzero .or. - & dimag( h(j+1,j) ) .ne. rzero ) then - t = h(j+1,j) / dlapy2(dble(h(j+1,j)),dimag(h(j+1,j))) - call zscal( kplusp-j+1, conjg(t), h(j+1,j), ldh ) - call zscal( min(j+2, kplusp), t, h(1,j+1), 1 ) - call zscal( min(j+np+1,kplusp), t, q(1,j+1), 1 ) - h(j+1,j) = dcmplx( dble( h(j+1,j) ), rzero ) - end if - 120 continue -c - do 130 i = 1, kev -c -c %--------------------------------------------% -c | Final check for splitting and deflation. | -c | Use a standard test as in the QR algorithm | -c | REFERENCE: LAPACK subroutine zlahqr. | -c | Note: Since the subdiagonals of the | -c | compressed H are nonnegative real numbers, | -c | we take advantage of this. | -c %--------------------------------------------% -c - tst1 = zabs1( h( i, i ) ) + zabs1( h( i+1, i+1 ) ) - if( tst1 .eq. rzero ) - & tst1 = zlanhs( '1', kev, h, ldh, workl ) - if( dble( h( i+1,i ) ) .le. max( ulp*tst1, smlnum ) ) - & h(i+1,i) = zero - 130 continue -c -c %-------------------------------------------------% -c | Compute the (kev+1)-st column of (V*Q) and | -c | temporarily store the result in WORKD(N+1:2*N). | -c | This is needed in the residual update since we | -c | cannot GUARANTEE that the corresponding entry | -c | of H would be zero as in exact arithmetic. | -c %-------------------------------------------------% -c - if ( dble( h(kev+1,kev) ) .gt. rzero ) - & call zgemv ('N', n, kplusp, one, v, ldv, q(1,kev+1), 1, zero, - & workd(n+1), 1) -c -c %----------------------------------------------------------% -c | Compute column 1 to kev of (V*Q) in backward order | -c | taking advantage of the upper Hessenberg structure of Q. | -c %----------------------------------------------------------% -c - do 140 i = 1, kev - call zgemv ('N', n, kplusp-i+1, one, v, ldv, - & q(1,kev-i+1), 1, zero, workd, 1) - call zcopy (n, workd, 1, v(1,kplusp-i+1), 1) - 140 continue -c -c %-------------------------------------------------% -c | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). | -c %-------------------------------------------------% -c - call zlacpy ('A', n, kev, v(1,kplusp-kev+1), ldv, v, ldv) -c -c %--------------------------------------------------------------% -c | Copy the (kev+1)-st column of (V*Q) in the appropriate place | -c %--------------------------------------------------------------% -c - if ( dble( h(kev+1,kev) ) .gt. rzero ) - & call zcopy (n, workd(n+1), 1, v(1,kev+1), 1) -c -c %-------------------------------------% -c | Update the residual vector: | -c | r <- sigmak*r + betak*v(:,kev+1) | -c | where | -c | sigmak = (e_{kev+p}'*Q)*e_{kev} | -c | betak = e_{kev+1}'*H*e_{kev} | -c %-------------------------------------% -c - call zscal (n, q(kplusp,kev), resid, 1) - if ( dble( h(kev+1,kev) ) .gt. rzero ) - & call zaxpy (n, h(kev+1,kev), v(1,kev+1), 1, resid, 1) -c - if (msglvl .gt. 1) then - call zvout (logfil, 1, q(kplusp,kev), ndigit, - & '_napps: sigmak = (e_{kev+p}^T*Q)*e_{kev}') - call zvout (logfil, 1, h(kev+1,kev), ndigit, - & '_napps: betak = e_{kev+1}^T*H*e_{kev}') - call ivout (logfil, 1, kev, ndigit, - & '_napps: Order of the final Hessenberg matrix ') - if (msglvl .gt. 2) then - call zmout (logfil, kev, kev, h, ldh, ndigit, - & '_napps: updated Hessenberg matrix H for next iteration') - end if -c - end if -c - 9000 continue - call arscnd (t1) - tcapps = tcapps + (t1 - t0) -c - return -c -c %---------------% -c | End of znapps | -c %---------------% -c - end
--- a/libcruft/arpack/src/znaup2.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,801 +0,0 @@ -c\BeginDoc -c -c\Name: znaup2 -c -c\Description: -c Intermediate level interface called by znaupd . -c -c\Usage: -c call znaup2 -c ( IDO, BMAT, N, WHICH, NEV, NP, TOL, RESID, MODE, IUPD, -c ISHIFT, MXITER, V, LDV, H, LDH, RITZ, BOUNDS, -c Q, LDQ, WORKL, IPNTR, WORKD, RWORK, INFO ) -c -c\Arguments -c -c IDO, BMAT, N, WHICH, NEV, TOL, RESID: same as defined in znaupd . -c MODE, ISHIFT, MXITER: see the definition of IPARAM in znaupd . -c -c NP Integer. (INPUT/OUTPUT) -c Contains the number of implicit shifts to apply during -c each Arnoldi iteration. -c If ISHIFT=1, NP is adjusted dynamically at each iteration -c to accelerate convergence and prevent stagnation. -c This is also roughly equal to the number of matrix-vector -c products (involving the operator OP) per Arnoldi iteration. -c The logic for adjusting is contained within the current -c subroutine. -c If ISHIFT=0, NP is the number of shifts the user needs -c to provide via reverse comunication. 0 < NP < NCV-NEV. -c NP may be less than NCV-NEV since a leading block of the current -c upper Hessenberg matrix has split off and contains "unwanted" -c Ritz values. -c Upon termination of the IRA iteration, NP contains the number -c of "converged" wanted Ritz values. -c -c IUPD Integer. (INPUT) -c IUPD .EQ. 0: use explicit restart instead implicit update. -c IUPD .NE. 0: use implicit update. -c -c V Complex*16 N by (NEV+NP) array. (INPUT/OUTPUT) -c The Arnoldi basis vectors are returned in the first NEV -c columns of V. -c -c LDV Integer. (INPUT) -c Leading dimension of V exactly as declared in the calling -c program. -c -c H Complex*16 (NEV+NP) by (NEV+NP) array. (OUTPUT) -c H is used to store the generated upper Hessenberg matrix -c -c LDH Integer. (INPUT) -c Leading dimension of H exactly as declared in the calling -c program. -c -c RITZ Complex*16 array of length NEV+NP. (OUTPUT) -c RITZ(1:NEV) contains the computed Ritz values of OP. -c -c BOUNDS Complex*16 array of length NEV+NP. (OUTPUT) -c BOUNDS(1:NEV) contain the error bounds corresponding to -c the computed Ritz values. -c -c Q Complex*16 (NEV+NP) by (NEV+NP) array. (WORKSPACE) -c Private (replicated) work array used to accumulate the -c rotation in the shift application step. -c -c LDQ Integer. (INPUT) -c Leading dimension of Q exactly as declared in the calling -c program. -c -c WORKL Complex*16 work array of length at least -c (NEV+NP)**2 + 3*(NEV+NP). (WORKSPACE) -c Private (replicated) array on each PE or array allocated on -c the front end. It is used in shifts calculation, shifts -c application and convergence checking. -c -c -c IPNTR Integer array of length 3. (OUTPUT) -c Pointer to mark the starting locations in the WORKD for -c vectors used by the Arnoldi iteration. -c ------------------------------------------------------------- -c IPNTR(1): pointer to the current operand vector X. -c IPNTR(2): pointer to the current result vector Y. -c IPNTR(3): pointer to the vector B * X when used in the -c shift-and-invert mode. X is the current operand. -c ------------------------------------------------------------- -c -c WORKD Complex*16 work array of length 3*N. (WORKSPACE) -c Distributed array to be used in the basic Arnoldi iteration -c for reverse communication. The user should not use WORKD -c as temporary workspace during the iteration !!!!!!!!!! -c See Data Distribution Note in ZNAUPD . -c -c RWORK Double precision work array of length NEV+NP ( WORKSPACE) -c Private (replicated) array on each PE or array allocated on -c the front end. -c -c INFO Integer. (INPUT/OUTPUT) -c If INFO .EQ. 0, a randomly initial residual vector is used. -c If INFO .NE. 0, RESID contains the initial residual vector, -c possibly from a previous run. -c Error flag on output. -c = 0: Normal return. -c = 1: Maximum number of iterations taken. -c All possible eigenvalues of OP has been found. -c NP returns the number of converged Ritz values. -c = 2: No shifts could be applied. -c = -8: Error return from LAPACK eigenvalue calculation; -c This should never happen. -c = -9: Starting vector is zero. -c = -9999: Could not build an Arnoldi factorization. -c Size that was built in returned in NP. -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Local variables: -c xxxxxx Complex*16 -c -c\References: -c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in -c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), -c pp 357-385. -c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly -c Restarted Arnoldi Iteration", Rice University Technical Report -c TR95-13, Department of Computational and Applied Mathematics. -c -c\Routines called: -c zgetv0 ARPACK initial vector generation routine. -c znaitr ARPACK Arnoldi factorization routine. -c znapps ARPACK application of implicit shifts routine. -c zneigh ARPACK compute Ritz values and error bounds routine. -c zngets ARPACK reorder Ritz values and error bounds routine. -c zsortc ARPACK sorting routine. -c ivout ARPACK utility routine that prints integers. -c arscnd ARPACK utility routine for timing. -c zmout ARPACK utility routine that prints matrices -c zvout ARPACK utility routine that prints vectors. -c dvout ARPACK utility routine that prints vectors. -c dlamch LAPACK routine that determines machine constants. -c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. -c zcopy Level 1 BLAS that copies one vector to another . -c zdotc Level 1 BLAS that computes the scalar product of two vectors. -c zswap Level 1 BLAS that swaps two vectors. -c dznrm2 Level 1 BLAS that computes the norm of a vector. -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice Universitya -c Chao Yang Houston, Texas -c Dept. of Computational & -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\SCCS Information: @(#) -c FILE: naup2.F SID: 2.6 DATE OF SID: 06/01/00 RELEASE: 2 -c -c\Remarks -c 1. None -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine znaup2 - & ( ido, bmat, n, which, nev, np, tol, resid, mode, iupd, - & ishift, mxiter, v, ldv, h, ldh, ritz, bounds, - & q, ldq, workl, ipntr, workd, rwork, info ) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - character bmat*1, which*2 - integer ido, info, ishift, iupd, mode, ldh, ldq, ldv, mxiter, - & n, nev, np - Double precision - & tol -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - integer ipntr(13) - Complex*16 - & bounds(nev+np), h(ldh,nev+np), q(ldq,nev+np), - & resid(n), ritz(nev+np), v(ldv,nev+np), - & workd(3*n), workl( (nev+np)*(nev+np+3) ) - Double precision - & rwork(nev+np) -c -c %------------% -c | Parameters | -c %------------% -c - Complex*16 - & one, zero - Double precision - & rzero - parameter (one = (1.0D+0, 0.0D+0) , zero = (0.0D+0, 0.0D+0) , - & rzero = 0.0D+0 ) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - logical cnorm , getv0, initv , update, ushift - integer ierr , iter , kplusp, msglvl, nconv, - & nevbef, nev0 , np0 , nptemp, i , - & j - Complex*16 - & cmpnorm - Double precision - & rnorm , eps23, rtemp - character wprime*2 -c - save cnorm, getv0, initv , update, ushift, - & rnorm, iter , kplusp, msglvl, nconv , - & nevbef, nev0 , np0 , eps23 -c -c -c %-----------------------% -c | Local array arguments | -c %-----------------------% -c - integer kp(3) -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external zcopy , zgetv0 , znaitr , zneigh , zngets , znapps , - & zsortc , zswap , zmout , zvout , ivout, arscnd -c -c %--------------------% -c | External functions | -c %--------------------% -c - Complex*16 - & zdotc - Double precision - & dznrm2 , dlamch , dlapy2 - external zdotc , dznrm2 , dlamch , dlapy2 -c -c %---------------------% -c | Intrinsic Functions | -c %---------------------% -c - intrinsic dimag , dble , min, max -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c - if (ido .eq. 0) then -c - call arscnd (t0) -c - msglvl = mcaup2 -c - nev0 = nev - np0 = np -c -c %-------------------------------------% -c | kplusp is the bound on the largest | -c | Lanczos factorization built. | -c | nconv is the current number of | -c | "converged" eigenvalues. | -c | iter is the counter on the current | -c | iteration step. | -c %-------------------------------------% -c - kplusp = nev + np - nconv = 0 - iter = 0 -c -c %---------------------------------% -c | Get machine dependent constant. | -c %---------------------------------% -c - eps23 = dlamch ('Epsilon-Machine') - eps23 = eps23**(2.0D+0 / 3.0D+0 ) -c -c %---------------------------------------% -c | Set flags for computing the first NEV | -c | steps of the Arnoldi factorization. | -c %---------------------------------------% -c - getv0 = .true. - update = .false. - ushift = .false. - cnorm = .false. -c - if (info .ne. 0) then -c -c %--------------------------------------------% -c | User provides the initial residual vector. | -c %--------------------------------------------% -c - initv = .true. - info = 0 - else - initv = .false. - end if - end if -c -c %---------------------------------------------% -c | Get a possibly random starting vector and | -c | force it into the range of the operator OP. | -c %---------------------------------------------% -c - 10 continue -c - if (getv0) then - call zgetv0 (ido, bmat, 1, initv, n, 1, v, ldv, resid, rnorm, - & ipntr, workd, info) -c - if (ido .ne. 99) go to 9000 -c - if (rnorm .eq. rzero) then -c -c %-----------------------------------------% -c | The initial vector is zero. Error exit. | -c %-----------------------------------------% -c - info = -9 - go to 1100 - end if - getv0 = .false. - ido = 0 - end if -c -c %-----------------------------------% -c | Back from reverse communication : | -c | continue with update step | -c %-----------------------------------% -c - if (update) go to 20 -c -c %-------------------------------------------% -c | Back from computing user specified shifts | -c %-------------------------------------------% -c - if (ushift) go to 50 -c -c %-------------------------------------% -c | Back from computing residual norm | -c | at the end of the current iteration | -c %-------------------------------------% -c - if (cnorm) go to 100 -c -c %----------------------------------------------------------% -c | Compute the first NEV steps of the Arnoldi factorization | -c %----------------------------------------------------------% -c - call znaitr (ido, bmat, n, 0, nev, mode, resid, rnorm, v, ldv, - & h, ldh, ipntr, workd, info) -c - if (ido .ne. 99) go to 9000 -c - if (info .gt. 0) then - np = info - mxiter = iter - info = -9999 - go to 1200 - end if -c -c %--------------------------------------------------------------% -c | | -c | M A I N ARNOLDI I T E R A T I O N L O O P | -c | Each iteration implicitly restarts the Arnoldi | -c | factorization in place. | -c | | -c %--------------------------------------------------------------% -c - 1000 continue -c - iter = iter + 1 -c - if (msglvl .gt. 0) then - call ivout (logfil, 1, iter, ndigit, - & '_naup2: **** Start of major iteration number ****') - end if -c -c %-----------------------------------------------------------% -c | Compute NP additional steps of the Arnoldi factorization. | -c | Adjust NP since NEV might have been updated by last call | -c | to the shift application routine znapps . | -c %-----------------------------------------------------------% -c - np = kplusp - nev -c - if (msglvl .gt. 1) then - call ivout (logfil, 1, nev, ndigit, - & '_naup2: The length of the current Arnoldi factorization') - call ivout (logfil, 1, np, ndigit, - & '_naup2: Extend the Arnoldi factorization by') - end if -c -c %-----------------------------------------------------------% -c | Compute NP additional steps of the Arnoldi factorization. | -c %-----------------------------------------------------------% -c - ido = 0 - 20 continue - update = .true. -c - call znaitr (ido, bmat, n, nev, np, mode, resid, rnorm, - & v , ldv , h, ldh, ipntr, workd, info) -c - if (ido .ne. 99) go to 9000 -c - if (info .gt. 0) then - np = info - mxiter = iter - info = -9999 - go to 1200 - end if - update = .false. -c - if (msglvl .gt. 1) then - call dvout (logfil, 1, rnorm, ndigit, - & '_naup2: Corresponding B-norm of the residual') - end if -c -c %--------------------------------------------------------% -c | Compute the eigenvalues and corresponding error bounds | -c | of the current upper Hessenberg matrix. | -c %--------------------------------------------------------% -c - call zneigh (rnorm, kplusp, h, ldh, ritz, bounds, - & q, ldq, workl, rwork, ierr) -c - if (ierr .ne. 0) then - info = -8 - go to 1200 - end if -c -c %---------------------------------------------------% -c | Select the wanted Ritz values and their bounds | -c | to be used in the convergence test. | -c | The wanted part of the spectrum and corresponding | -c | error bounds are in the last NEV loc. of RITZ, | -c | and BOUNDS respectively. | -c %---------------------------------------------------% -c - nev = nev0 - np = np0 -c -c %--------------------------------------------------% -c | Make a copy of Ritz values and the corresponding | -c | Ritz estimates obtained from zneigh . | -c %--------------------------------------------------% -c - call zcopy (kplusp,ritz,1,workl(kplusp**2+1),1) - call zcopy (kplusp,bounds,1,workl(kplusp**2+kplusp+1),1) -c -c %---------------------------------------------------% -c | Select the wanted Ritz values and their bounds | -c | to be used in the convergence test. | -c | The wanted part of the spectrum and corresponding | -c | bounds are in the last NEV loc. of RITZ | -c | BOUNDS respectively. | -c %---------------------------------------------------% -c - call zngets (ishift, which, nev, np, ritz, bounds) -c -c %------------------------------------------------------------% -c | Convergence test: currently we use the following criteria. | -c | The relative accuracy of a Ritz value is considered | -c | acceptable if: | -c | | -c | error_bounds(i) .le. tol*max(eps23, magnitude_of_ritz(i)). | -c | | -c %------------------------------------------------------------% -c - nconv = 0 -c - do 25 i = 1, nev - rtemp = max( eps23, dlapy2 ( dble (ritz(np+i)), - & dimag (ritz(np+i)) ) ) - if ( dlapy2 (dble (bounds(np+i)),dimag (bounds(np+i))) - & .le. tol*rtemp ) then - nconv = nconv + 1 - end if - 25 continue -c - if (msglvl .gt. 2) then - kp(1) = nev - kp(2) = np - kp(3) = nconv - call ivout (logfil, 3, kp, ndigit, - & '_naup2: NEV, NP, NCONV are') - call zvout (logfil, kplusp, ritz, ndigit, - & '_naup2: The eigenvalues of H') - call zvout (logfil, kplusp, bounds, ndigit, - & '_naup2: Ritz estimates of the current NCV Ritz values') - end if -c -c %---------------------------------------------------------% -c | Count the number of unwanted Ritz values that have zero | -c | Ritz estimates. If any Ritz estimates are equal to zero | -c | then a leading block of H of order equal to at least | -c | the number of Ritz values with zero Ritz estimates has | -c | split off. None of these Ritz values may be removed by | -c | shifting. Decrease NP the number of shifts to apply. If | -c | no shifts may be applied, then prepare to exit | -c %---------------------------------------------------------% -c - nptemp = np - do 30 j=1, nptemp - if (bounds(j) .eq. zero) then - np = np - 1 - nev = nev + 1 - end if - 30 continue -c - if ( (nconv .ge. nev0) .or. - & (iter .gt. mxiter) .or. - & (np .eq. 0) ) then -c - if (msglvl .gt. 4) then - call zvout (logfil, kplusp, workl(kplusp**2+1), ndigit, - & '_naup2: Eigenvalues computed by _neigh:') - call zvout (logfil, kplusp, workl(kplusp**2+kplusp+1), - & ndigit, - & '_naup2: Ritz estimates computed by _neigh:') - end if -c -c %------------------------------------------------% -c | Prepare to exit. Put the converged Ritz values | -c | and corresponding bounds in RITZ(1:NCONV) and | -c | BOUNDS(1:NCONV) respectively. Then sort. Be | -c | careful when NCONV > NP | -c %------------------------------------------------% -c -c %------------------------------------------% -c | Use h( 3,1 ) as storage to communicate | -c | rnorm to zneupd if needed | -c %------------------------------------------% - - h(3,1) = dcmplx (rnorm,rzero) -c -c %----------------------------------------------% -c | Sort Ritz values so that converged Ritz | -c | values appear within the first NEV locations | -c | of ritz and bounds, and the most desired one | -c | appears at the front. | -c %----------------------------------------------% -c - if (which .eq. 'LM') wprime = 'SM' - if (which .eq. 'SM') wprime = 'LM' - if (which .eq. 'LR') wprime = 'SR' - if (which .eq. 'SR') wprime = 'LR' - if (which .eq. 'LI') wprime = 'SI' - if (which .eq. 'SI') wprime = 'LI' -c - call zsortc (wprime, .true., kplusp, ritz, bounds) -c -c %--------------------------------------------------% -c | Scale the Ritz estimate of each Ritz value | -c | by 1 / max(eps23, magnitude of the Ritz value). | -c %--------------------------------------------------% -c - do 35 j = 1, nev0 - rtemp = max( eps23, dlapy2 ( dble (ritz(j)), - & dimag (ritz(j)) ) ) - bounds(j) = bounds(j)/rtemp - 35 continue -c -c %---------------------------------------------------% -c | Sort the Ritz values according to the scaled Ritz | -c | estimates. This will push all the converged ones | -c | towards the front of ritz, bounds (in the case | -c | when NCONV < NEV.) | -c %---------------------------------------------------% -c - wprime = 'LM' - call zsortc (wprime, .true., nev0, bounds, ritz) -c -c %----------------------------------------------% -c | Scale the Ritz estimate back to its original | -c | value. | -c %----------------------------------------------% -c - do 40 j = 1, nev0 - rtemp = max( eps23, dlapy2 ( dble (ritz(j)), - & dimag (ritz(j)) ) ) - bounds(j) = bounds(j)*rtemp - 40 continue -c -c %-----------------------------------------------% -c | Sort the converged Ritz values again so that | -c | the "threshold" value appears at the front of | -c | ritz and bound. | -c %-----------------------------------------------% -c - call zsortc (which, .true., nconv, ritz, bounds) -c - if (msglvl .gt. 1) then - call zvout (logfil, kplusp, ritz, ndigit, - & '_naup2: Sorted eigenvalues') - call zvout (logfil, kplusp, bounds, ndigit, - & '_naup2: Sorted ritz estimates.') - end if -c -c %------------------------------------% -c | Max iterations have been exceeded. | -c %------------------------------------% -c - if (iter .gt. mxiter .and. nconv .lt. nev0) info = 1 -c -c %---------------------% -c | No shifts to apply. | -c %---------------------% -c - if (np .eq. 0 .and. nconv .lt. nev0) info = 2 -c - np = nconv - go to 1100 -c - else if ( (nconv .lt. nev0) .and. (ishift .eq. 1) ) then -c -c %-------------------------------------------------% -c | Do not have all the requested eigenvalues yet. | -c | To prevent possible stagnation, adjust the size | -c | of NEV. | -c %-------------------------------------------------% -c - nevbef = nev - nev = nev + min(nconv, np/2) - if (nev .eq. 1 .and. kplusp .ge. 6) then - nev = kplusp / 2 - else if (nev .eq. 1 .and. kplusp .gt. 3) then - nev = 2 - end if - np = kplusp - nev -c -c %---------------------------------------% -c | If the size of NEV was just increased | -c | resort the eigenvalues. | -c %---------------------------------------% -c - if (nevbef .lt. nev) - & call zngets (ishift, which, nev, np, ritz, bounds) -c - end if -c - if (msglvl .gt. 0) then - call ivout (logfil, 1, nconv, ndigit, - & '_naup2: no. of "converged" Ritz values at this iter.') - if (msglvl .gt. 1) then - kp(1) = nev - kp(2) = np - call ivout (logfil, 2, kp, ndigit, - & '_naup2: NEV and NP are') - call zvout (logfil, nev, ritz(np+1), ndigit, - & '_naup2: "wanted" Ritz values ') - call zvout (logfil, nev, bounds(np+1), ndigit, - & '_naup2: Ritz estimates of the "wanted" values ') - end if - end if -c - if (ishift .eq. 0) then -c -c %-------------------------------------------------------% -c | User specified shifts: pop back out to get the shifts | -c | and return them in the first 2*NP locations of WORKL. | -c %-------------------------------------------------------% -c - ushift = .true. - ido = 3 - go to 9000 - end if - 50 continue - ushift = .false. -c - if ( ishift .ne. 1 ) then -c -c %----------------------------------% -c | Move the NP shifts from WORKL to | -c | RITZ, to free up WORKL | -c | for non-exact shift case. | -c %----------------------------------% -c - call zcopy (np, workl, 1, ritz, 1) - end if -c - if (msglvl .gt. 2) then - call ivout (logfil, 1, np, ndigit, - & '_naup2: The number of shifts to apply ') - call zvout (logfil, np, ritz, ndigit, - & '_naup2: values of the shifts') - if ( ishift .eq. 1 ) - & call zvout (logfil, np, bounds, ndigit, - & '_naup2: Ritz estimates of the shifts') - end if -c -c %---------------------------------------------------------% -c | Apply the NP implicit shifts by QR bulge chasing. | -c | Each shift is applied to the whole upper Hessenberg | -c | matrix H. | -c | The first 2*N locations of WORKD are used as workspace. | -c %---------------------------------------------------------% -c - call znapps (n, nev, np, ritz, v, ldv, - & h, ldh, resid, q, ldq, workl, workd) -c -c %---------------------------------------------% -c | Compute the B-norm of the updated residual. | -c | Keep B*RESID in WORKD(1:N) to be used in | -c | the first step of the next call to znaitr . | -c %---------------------------------------------% -c - cnorm = .true. - call arscnd (t2) - if (bmat .eq. 'G') then - nbx = nbx + 1 - call zcopy (n, resid, 1, workd(n+1), 1) - ipntr(1) = n + 1 - ipntr(2) = 1 - ido = 2 -c -c %----------------------------------% -c | Exit in order to compute B*RESID | -c %----------------------------------% -c - go to 9000 - else if (bmat .eq. 'I') then - call zcopy (n, resid, 1, workd, 1) - end if -c - 100 continue -c -c %----------------------------------% -c | Back from reverse communication; | -c | WORKD(1:N) := B*RESID | -c %----------------------------------% -c - if (bmat .eq. 'G') then - call arscnd (t3) - tmvbx = tmvbx + (t3 - t2) - end if -c - if (bmat .eq. 'G') then - cmpnorm = zdotc (n, resid, 1, workd, 1) - rnorm = sqrt(dlapy2 (dble (cmpnorm),dimag (cmpnorm))) - else if (bmat .eq. 'I') then - rnorm = dznrm2 (n, resid, 1) - end if - cnorm = .false. -c - if (msglvl .gt. 2) then - call dvout (logfil, 1, rnorm, ndigit, - & '_naup2: B-norm of residual for compressed factorization') - call zmout (logfil, nev, nev, h, ldh, ndigit, - & '_naup2: Compressed upper Hessenberg matrix H') - end if -c - go to 1000 -c -c %---------------------------------------------------------------% -c | | -c | E N D O F M A I N I T E R A T I O N L O O P | -c | | -c %---------------------------------------------------------------% -c - 1100 continue -c - mxiter = iter - nev = nconv -c - 1200 continue - ido = 99 -c -c %------------% -c | Error Exit | -c %------------% -c - call arscnd (t1) - tcaup2 = t1 - t0 -c - 9000 continue -c -c %---------------% -c | End of znaup2 | -c %---------------% -c - return - end
--- a/libcruft/arpack/src/znaupd.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,664 +0,0 @@ -c\BeginDoc -c -c\Name: znaupd -c -c\Description: -c Reverse communication interface for the Implicitly Restarted Arnoldi -c iteration. This is intended to be used to find a few eigenpairs of a -c complex linear operator OP with respect to a semi-inner product defined -c by a hermitian positive semi-definite real matrix B. B may be the identity -c matrix. NOTE: if both OP and B are real, then dsaupd or dnaupd should -c be used. -c -c -c The computed approximate eigenvalues are called Ritz values and -c the corresponding approximate eigenvectors are called Ritz vectors. -c -c znaupd is usually called iteratively to solve one of the -c following problems: -c -c Mode 1: A*x = lambda*x. -c ===> OP = A and B = I. -c -c Mode 2: A*x = lambda*M*x, M hermitian positive definite -c ===> OP = inv[M]*A and B = M. -c ===> (If M can be factored see remark 3 below) -c -c Mode 3: A*x = lambda*M*x, M hermitian semi-definite -c ===> OP = inv[A - sigma*M]*M and B = M. -c ===> shift-and-invert mode -c If OP*x = amu*x, then lambda = sigma + 1/amu. -c -c -c NOTE: The action of w <- inv[A - sigma*M]*v or w <- inv[M]*v -c should be accomplished either by a direct method -c using a sparse matrix factorization and solving -c -c [A - sigma*M]*w = v or M*w = v, -c -c or through an iterative method for solving these -c systems. If an iterative method is used, the -c convergence test must be more stringent than -c the accuracy requirements for the eigenvalue -c approximations. -c -c\Usage: -c call znaupd -c ( IDO, BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, -c IPNTR, WORKD, WORKL, LWORKL, RWORK, INFO ) -c -c\Arguments -c IDO Integer. (INPUT/OUTPUT) -c Reverse communication flag. IDO must be zero on the first -c call to znaupd . IDO will be set internally to -c indicate the type of operation to be performed. Control is -c then given back to the calling routine which has the -c responsibility to carry out the requested operation and call -c znaupd with the result. The operand is given in -c WORKD(IPNTR(1)), the result must be put in WORKD(IPNTR(2)). -c ------------------------------------------------------------- -c IDO = 0: first call to the reverse communication interface -c IDO = -1: compute Y = OP * X where -c IPNTR(1) is the pointer into WORKD for X, -c IPNTR(2) is the pointer into WORKD for Y. -c This is for the initialization phase to force the -c starting vector into the range of OP. -c IDO = 1: compute Y = OP * X where -c IPNTR(1) is the pointer into WORKD for X, -c IPNTR(2) is the pointer into WORKD for Y. -c In mode 3, the vector B * X is already -c available in WORKD(ipntr(3)). It does not -c need to be recomputed in forming OP * X. -c IDO = 2: compute Y = M * X where -c IPNTR(1) is the pointer into WORKD for X, -c IPNTR(2) is the pointer into WORKD for Y. -c IDO = 3: compute and return the shifts in the first -c NP locations of WORKL. -c IDO = 99: done -c ------------------------------------------------------------- -c After the initialization phase, when the routine is used in -c the "shift-and-invert" mode, the vector M * X is already -c available and does not need to be recomputed in forming OP*X. -c -c BMAT Character*1. (INPUT) -c BMAT specifies the type of the matrix B that defines the -c semi-inner product for the operator OP. -c BMAT = 'I' -> standard eigenvalue problem A*x = lambda*x -c BMAT = 'G' -> generalized eigenvalue problem A*x = lambda*M*x -c -c N Integer. (INPUT) -c Dimension of the eigenproblem. -c -c WHICH Character*2. (INPUT) -c 'LM' -> want the NEV eigenvalues of largest magnitude. -c 'SM' -> want the NEV eigenvalues of smallest magnitude. -c 'LR' -> want the NEV eigenvalues of largest real part. -c 'SR' -> want the NEV eigenvalues of smallest real part. -c 'LI' -> want the NEV eigenvalues of largest imaginary part. -c 'SI' -> want the NEV eigenvalues of smallest imaginary part. -c -c NEV Integer. (INPUT) -c Number of eigenvalues of OP to be computed. 0 < NEV < N-1. -c -c TOL Double precision scalar. (INPUT) -c Stopping criteria: the relative accuracy of the Ritz value -c is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I)) -c where ABS(RITZ(I)) is the magnitude when RITZ(I) is complex. -c DEFAULT = dlamch ('EPS') (machine precision as computed -c by the LAPACK auxiliary subroutine dlamch ). -c -c RESID Complex*16 array of length N. (INPUT/OUTPUT) -c On INPUT: -c If INFO .EQ. 0, a random initial residual vector is used. -c If INFO .NE. 0, RESID contains the initial residual vector, -c possibly from a previous run. -c On OUTPUT: -c RESID contains the final residual vector. -c -c NCV Integer. (INPUT) -c Number of columns of the matrix V. NCV must satisfy the two -c inequalities 1 <= NCV-NEV and NCV <= N. -c This will indicate how many Arnoldi vectors are generated -c at each iteration. After the startup phase in which NEV -c Arnoldi vectors are generated, the algorithm generates -c approximately NCV-NEV Arnoldi vectors at each subsequent update -c iteration. Most of the cost in generating each Arnoldi vector is -c in the matrix-vector operation OP*x. (See remark 4 below.) -c -c V Complex*16 array N by NCV. (OUTPUT) -c Contains the final set of Arnoldi basis vectors. -c -c LDV Integer. (INPUT) -c Leading dimension of V exactly as declared in the calling program. -c -c IPARAM Integer array of length 11. (INPUT/OUTPUT) -c IPARAM(1) = ISHIFT: method for selecting the implicit shifts. -c The shifts selected at each iteration are used to filter out -c the components of the unwanted eigenvector. -c ------------------------------------------------------------- -c ISHIFT = 0: the shifts are to be provided by the user via -c reverse communication. The NCV eigenvalues of -c the Hessenberg matrix H are returned in the part -c of WORKL array corresponding to RITZ. -c ISHIFT = 1: exact shifts with respect to the current -c Hessenberg matrix H. This is equivalent to -c restarting the iteration from the beginning -c after updating the starting vector with a linear -c combination of Ritz vectors associated with the -c "wanted" eigenvalues. -c ISHIFT = 2: other choice of internal shift to be defined. -c ------------------------------------------------------------- -c -c IPARAM(2) = No longer referenced -c -c IPARAM(3) = MXITER -c On INPUT: maximum number of Arnoldi update iterations allowed. -c On OUTPUT: actual number of Arnoldi update iterations taken. -c -c IPARAM(4) = NB: blocksize to be used in the recurrence. -c The code currently works only for NB = 1. -c -c IPARAM(5) = NCONV: number of "converged" Ritz values. -c This represents the number of Ritz values that satisfy -c the convergence criterion. -c -c IPARAM(6) = IUPD -c No longer referenced. Implicit restarting is ALWAYS used. -c -c IPARAM(7) = MODE -c On INPUT determines what type of eigenproblem is being solved. -c Must be 1,2,3; See under \Description of znaupd for the -c four modes available. -c -c IPARAM(8) = NP -c When ido = 3 and the user provides shifts through reverse -c communication (IPARAM(1)=0), _naupd returns NP, the number -c of shifts the user is to provide. 0 < NP < NCV-NEV. -c -c IPARAM(9) = NUMOP, IPARAM(10) = NUMOPB, IPARAM(11) = NUMREO, -c OUTPUT: NUMOP = total number of OP*x operations, -c NUMOPB = total number of B*x operations if BMAT='G', -c NUMREO = total number of steps of re-orthogonalization. -c -c IPNTR Integer array of length 14. (OUTPUT) -c Pointer to mark the starting locations in the WORKD and WORKL -c arrays for matrices/vectors used by the Arnoldi iteration. -c ------------------------------------------------------------- -c IPNTR(1): pointer to the current operand vector X in WORKD. -c IPNTR(2): pointer to the current result vector Y in WORKD. -c IPNTR(3): pointer to the vector B * X in WORKD when used in -c the shift-and-invert mode. -c IPNTR(4): pointer to the next available location in WORKL -c that is untouched by the program. -c IPNTR(5): pointer to the NCV by NCV upper Hessenberg -c matrix H in WORKL. -c IPNTR(6): pointer to the ritz value array RITZ -c IPNTR(7): pointer to the (projected) ritz vector array Q -c IPNTR(8): pointer to the error BOUNDS array in WORKL. -c IPNTR(14): pointer to the NP shifts in WORKL. See Remark 5 below. -c -c Note: IPNTR(9:13) is only referenced by zneupd . See Remark 2 below. -c -c IPNTR(9): pointer to the NCV RITZ values of the -c original system. -c IPNTR(10): Not Used -c IPNTR(11): pointer to the NCV corresponding error bounds. -c IPNTR(12): pointer to the NCV by NCV upper triangular -c Schur matrix for H. -c IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors -c of the upper Hessenberg matrix H. Only referenced by -c zneupd if RVEC = .TRUE. See Remark 2 below. -c -c ------------------------------------------------------------- -c -c WORKD Complex*16 work array of length 3*N. (REVERSE COMMUNICATION) -c Distributed array to be used in the basic Arnoldi iteration -c for reverse communication. The user should not use WORKD -c as temporary workspace during the iteration !!!!!!!!!! -c See Data Distribution Note below. -c -c WORKL Complex*16 work array of length LWORKL. (OUTPUT/WORKSPACE) -c Private (replicated) array on each PE or array allocated on -c the front end. See Data Distribution Note below. -c -c LWORKL Integer. (INPUT) -c LWORKL must be at least 3*NCV**2 + 5*NCV. -c -c RWORK Double precision work array of length NCV (WORKSPACE) -c Private (replicated) array on each PE or array allocated on -c the front end. -c -c -c INFO Integer. (INPUT/OUTPUT) -c If INFO .EQ. 0, a randomly initial residual vector is used. -c If INFO .NE. 0, RESID contains the initial residual vector, -c possibly from a previous run. -c Error flag on output. -c = 0: Normal exit. -c = 1: Maximum number of iterations taken. -c All possible eigenvalues of OP has been found. IPARAM(5) -c returns the number of wanted converged Ritz values. -c = 2: No longer an informational error. Deprecated starting -c with release 2 of ARPACK. -c = 3: No shifts could be applied during a cycle of the -c Implicitly restarted Arnoldi iteration. One possibility -c is to increase the size of NCV relative to NEV. -c See remark 4 below. -c = -1: N must be positive. -c = -2: NEV must be positive. -c = -3: NCV-NEV >= 2 and less than or equal to N. -c = -4: The maximum number of Arnoldi update iteration -c must be greater than zero. -c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI' -c = -6: BMAT must be one of 'I' or 'G'. -c = -7: Length of private work array is not sufficient. -c = -8: Error return from LAPACK eigenvalue calculation; -c = -9: Starting vector is zero. -c = -10: IPARAM(7) must be 1,2,3. -c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. -c = -12: IPARAM(1) must be equal to 0 or 1. -c = -9999: Could not build an Arnoldi factorization. -c User input error highly likely. Please -c check actual array dimensions and layout. -c IPARAM(5) returns the size of the current Arnoldi -c factorization. -c -c\Remarks -c 1. The computed Ritz values are approximate eigenvalues of OP. The -c selection of WHICH should be made with this in mind when using -c Mode = 3. When operating in Mode = 3 setting WHICH = 'LM' will -c compute the NEV eigenvalues of the original problem that are -c closest to the shift SIGMA . After convergence, approximate eigenvalues -c of the original problem may be obtained with the ARPACK subroutine zneupd . -c -c 2. If a basis for the invariant subspace corresponding to the converged Ritz -c values is needed, the user must call zneupd immediately following -c completion of znaupd . This is new starting with release 2 of ARPACK. -c -c 3. If M can be factored into a Cholesky factorization M = LL` -c then Mode = 2 should not be selected. Instead one should use -c Mode = 1 with OP = inv(L)*A*inv(L`). Appropriate triangular -c linear systems should be solved with L and L` rather -c than computing inverses. After convergence, an approximate -c eigenvector z of the original problem is recovered by solving -c L`z = x where x is a Ritz vector of OP. -c -c 4. At present there is no a-priori analysis to guide the selection -c of NCV relative to NEV. The only formal requirement is that NCV > NEV + 1. -c However, it is recommended that NCV .ge. 2*NEV. If many problems of -c the same type are to be solved, one should experiment with increasing -c NCV while keeping NEV fixed for a given test problem. This will -c usually decrease the required number of OP*x operations but it -c also increases the work and storage required to maintain the orthogonal -c basis vectors. The optimal "cross-over" with respect to CPU time -c is problem dependent and must be determined empirically. -c See Chapter 8 of Reference 2 for further information. -c -c 5. When IPARAM(1) = 0, and IDO = 3, the user needs to provide the -c NP = IPARAM(8) complex shifts in locations -c WORKL(IPNTR(14)), WORKL(IPNTR(14)+1), ... , WORKL(IPNTR(14)+NP). -c Eigenvalues of the current upper Hessenberg matrix are located in -c WORKL(IPNTR(6)) through WORKL(IPNTR(6)+NCV-1). They are ordered -c according to the order defined by WHICH. The associated Ritz estimates -c are located in WORKL(IPNTR(8)), WORKL(IPNTR(8)+1), ... , -c WORKL(IPNTR(8)+NCV-1). -c -c----------------------------------------------------------------------- -c -c\Data Distribution Note: -c -c Fortran-D syntax: -c ================ -c Complex*16 resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) -c decompose d1(n), d2(n,ncv) -c align resid(i) with d1(i) -c align v(i,j) with d2(i,j) -c align workd(i) with d1(i) range (1:n) -c align workd(i) with d1(i-n) range (n+1:2*n) -c align workd(i) with d1(i-2*n) range (2*n+1:3*n) -c distribute d1(block), d2(block,:) -c replicated workl(lworkl) -c -c Cray MPP syntax: -c =============== -c Complex*16 resid(n), v(ldv,ncv), workd(n,3), workl(lworkl) -c shared resid(block), v(block,:), workd(block,:) -c replicated workl(lworkl) -c -c CM2/CM5 syntax: -c ============== -c -c----------------------------------------------------------------------- -c -c include 'ex-nonsym.doc' -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Local variables: -c xxxxxx Complex*16 -c -c\References: -c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in -c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), -c pp 357-385. -c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly -c Restarted Arnoldi Iteration", Rice University Technical Report -c TR95-13, Department of Computational and Applied Mathematics. -c 3. B.N. Parlett & Y. Saad, "_Complex_ Shift and Invert Strategies for -c _Real_ Matrices", Linear Algebra and its Applications, vol 88/89, -c pp 575-595, (1987). -c -c\Routines called: -c znaup2 ARPACK routine that implements the Implicitly Restarted -c Arnoldi Iteration. -c zstatn ARPACK routine that initializes the timing variables. -c ivout ARPACK utility routine that prints integers. -c zvout ARPACK utility routine that prints vectors. -c arscnd ARPACK utility routine for timing. -c dlamch LAPACK routine that determines machine constants. -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\SCCS Information: @(#) -c FILE: naupd.F SID: 2.8 DATE OF SID: 04/10/01 RELEASE: 2 -c -c\Remarks -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine znaupd - & ( ido, bmat, n, which, nev, tol, resid, ncv, v, ldv, iparam, - & ipntr, workd, workl, lworkl, rwork, info ) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - character bmat*1, which*2 - integer ido, info, ldv, lworkl, n, ncv, nev - Double precision - & tol -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - integer iparam(11), ipntr(14) - Complex*16 - & resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) - Double precision - & rwork(ncv) -c -c %------------% -c | Parameters | -c %------------% -c - Complex*16 - & one, zero - parameter (one = (1.0D+0, 0.0D+0) , zero = (0.0D+0, 0.0D+0) ) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - integer bounds, ierr, ih, iq, ishift, iupd, iw, - & ldh, ldq, levec, mode, msglvl, mxiter, nb, - & nev0, next, np, ritz, j - save bounds, ih, iq, ishift, iupd, iw, - & ldh, ldq, levec, mode, msglvl, mxiter, nb, - & nev0, next, np, ritz -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external znaup2 , zvout , ivout, arscnd, zstatn -c -c %--------------------% -c | External Functions | -c %--------------------% -c - Double precision - & dlamch - external dlamch -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c - if (ido .eq. 0) then -c -c %-------------------------------% -c | Initialize timing statistics | -c | & message level for debugging | -c %-------------------------------% -c - call zstatn - call arscnd (t0) - msglvl = mcaupd -c -c %----------------% -c | Error checking | -c %----------------% -c - ierr = 0 - ishift = iparam(1) -c levec = iparam(2) - mxiter = iparam(3) -c nb = iparam(4) - nb = 1 -c -c %--------------------------------------------% -c | Revision 2 performs only implicit restart. | -c %--------------------------------------------% -c - iupd = 1 - mode = iparam(7) -c - if (n .le. 0) then - ierr = -1 - else if (nev .le. 0) then - ierr = -2 - else if (ncv .le. nev .or. ncv .gt. n) then - ierr = -3 - else if (mxiter .le. 0) then - ierr = -4 - else if (which .ne. 'LM' .and. - & which .ne. 'SM' .and. - & which .ne. 'LR' .and. - & which .ne. 'SR' .and. - & which .ne. 'LI' .and. - & which .ne. 'SI') then - ierr = -5 - else if (bmat .ne. 'I' .and. bmat .ne. 'G') then - ierr = -6 - else if (lworkl .lt. 3*ncv**2 + 5*ncv) then - ierr = -7 - else if (mode .lt. 1 .or. mode .gt. 3) then - ierr = -10 - else if (mode .eq. 1 .and. bmat .eq. 'G') then - ierr = -11 - end if -c -c %------------% -c | Error Exit | -c %------------% -c - if (ierr .ne. 0) then - info = ierr - ido = 99 - go to 9000 - end if -c -c %------------------------% -c | Set default parameters | -c %------------------------% -c - if (nb .le. 0) nb = 1 - if (tol .le. 0.0D+0 ) tol = dlamch ('EpsMach') - if (ishift .ne. 0 .and. - & ishift .ne. 1 .and. - & ishift .ne. 2) ishift = 1 -c -c %----------------------------------------------% -c | NP is the number of additional steps to | -c | extend the length NEV Lanczos factorization. | -c | NEV0 is the local variable designating the | -c | size of the invariant subspace desired. | -c %----------------------------------------------% -c - np = ncv - nev - nev0 = nev -c -c %-----------------------------% -c | Zero out internal workspace | -c %-----------------------------% -c - do 10 j = 1, 3*ncv**2 + 5*ncv - workl(j) = zero - 10 continue -c -c %-------------------------------------------------------------% -c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | -c | etc... and the remaining workspace. | -c | Also update pointer to be used on output. | -c | Memory is laid out as follows: | -c | workl(1:ncv*ncv) := generated Hessenberg matrix | -c | workl(ncv*ncv+1:ncv*ncv+ncv) := the ritz values | -c | workl(ncv*ncv+ncv+1:ncv*ncv+2*ncv) := error bounds | -c | workl(ncv*ncv+2*ncv+1:2*ncv*ncv+2*ncv) := rotation matrix Q | -c | workl(2*ncv*ncv+2*ncv+1:3*ncv*ncv+5*ncv) := workspace | -c | The final workspace is needed by subroutine zneigh called | -c | by znaup2 . Subroutine zneigh calls LAPACK routines for | -c | calculating eigenvalues and the last row of the eigenvector | -c | matrix. | -c %-------------------------------------------------------------% -c - ldh = ncv - ldq = ncv - ih = 1 - ritz = ih + ldh*ncv - bounds = ritz + ncv - iq = bounds + ncv - iw = iq + ldq*ncv - next = iw + ncv**2 + 3*ncv -c - ipntr(4) = next - ipntr(5) = ih - ipntr(6) = ritz - ipntr(7) = iq - ipntr(8) = bounds - ipntr(14) = iw - end if -c -c %-------------------------------------------------------% -c | Carry out the Implicitly restarted Arnoldi Iteration. | -c %-------------------------------------------------------% -c - call znaup2 - & ( ido, bmat, n, which, nev0, np, tol, resid, mode, iupd, - & ishift, mxiter, v, ldv, workl(ih), ldh, workl(ritz), - & workl(bounds), workl(iq), ldq, workl(iw), - & ipntr, workd, rwork, info ) -c -c %--------------------------------------------------% -c | ido .ne. 99 implies use of reverse communication | -c | to compute operations involving OP. | -c %--------------------------------------------------% -c - if (ido .eq. 3) iparam(8) = np - if (ido .ne. 99) go to 9000 -c - iparam(3) = mxiter - iparam(5) = np - iparam(9) = nopx - iparam(10) = nbx - iparam(11) = nrorth -c -c %------------------------------------% -c | Exit if there was an informational | -c | error within znaup2 . | -c %------------------------------------% -c - if (info .lt. 0) go to 9000 - if (info .eq. 2) info = 3 -c - if (msglvl .gt. 0) then - call ivout (logfil, 1, mxiter, ndigit, - & '_naupd: Number of update iterations taken') - call ivout (logfil, 1, np, ndigit, - & '_naupd: Number of wanted "converged" Ritz values') - call zvout (logfil, np, workl(ritz), ndigit, - & '_naupd: The final Ritz values') - call zvout (logfil, np, workl(bounds), ndigit, - & '_naupd: Associated Ritz estimates') - end if -c - call arscnd (t1) - tcaupd = t1 - t0 -c - if (msglvl .gt. 0) then -c -c %--------------------------------------------------------% -c | Version Number & Version Date are defined in version.h | -c %--------------------------------------------------------% -c - write (6,1000) - write (6,1100) mxiter, nopx, nbx, nrorth, nitref, nrstrt, - & tmvopx, tmvbx, tcaupd, tcaup2, tcaitr, titref, - & tgetv0, tceigh, tcgets, tcapps, tcconv, trvec - 1000 format (//, - & 5x, '=============================================',/ - & 5x, '= Complex implicit Arnoldi update code =',/ - & 5x, '= Version Number: ', ' 2.3' , 21x, ' =',/ - & 5x, '= Version Date: ', ' 07/31/96' , 16x, ' =',/ - & 5x, '=============================================',/ - & 5x, '= Summary of timing statistics =',/ - & 5x, '=============================================',//) - 1100 format ( - & 5x, 'Total number update iterations = ', i5,/ - & 5x, 'Total number of OP*x operations = ', i5,/ - & 5x, 'Total number of B*x operations = ', i5,/ - & 5x, 'Total number of reorthogonalization steps = ', i5,/ - & 5x, 'Total number of iterative refinement steps = ', i5,/ - & 5x, 'Total number of restart steps = ', i5,/ - & 5x, 'Total time in user OP*x operation = ', f12.6,/ - & 5x, 'Total time in user B*x operation = ', f12.6,/ - & 5x, 'Total time in Arnoldi update routine = ', f12.6,/ - & 5x, 'Total time in naup2 routine = ', f12.6,/ - & 5x, 'Total time in basic Arnoldi iteration loop = ', f12.6,/ - & 5x, 'Total time in reorthogonalization phase = ', f12.6,/ - & 5x, 'Total time in (re)start vector generation = ', f12.6,/ - & 5x, 'Total time in Hessenberg eig. subproblem = ', f12.6,/ - & 5x, 'Total time in getting the shifts = ', f12.6,/ - & 5x, 'Total time in applying the shifts = ', f12.6,/ - & 5x, 'Total time in convergence testing = ', f12.6,/ - & 5x, 'Total time in computing final Ritz vectors = ', f12.6/) - end if -c - 9000 continue -c - return -c -c %---------------% -c | End of znaupd | -c %---------------% -c - end
--- a/libcruft/arpack/src/zneigh.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,257 +0,0 @@ -c\BeginDoc -c -c\Name: zneigh -c -c\Description: -c Compute the eigenvalues of the current upper Hessenberg matrix -c and the corresponding Ritz estimates given the current residual norm. -c -c\Usage: -c call zneigh -c ( RNORM, N, H, LDH, RITZ, BOUNDS, Q, LDQ, WORKL, RWORK, IERR ) -c -c\Arguments -c RNORM Double precision scalar. (INPUT) -c Residual norm corresponding to the current upper Hessenberg -c matrix H. -c -c N Integer. (INPUT) -c Size of the matrix H. -c -c H Complex*16 N by N array. (INPUT) -c H contains the current upper Hessenberg matrix. -c -c LDH Integer. (INPUT) -c Leading dimension of H exactly as declared in the calling -c program. -c -c RITZ Complex*16 array of length N. (OUTPUT) -c On output, RITZ(1:N) contains the eigenvalues of H. -c -c BOUNDS Complex*16 array of length N. (OUTPUT) -c On output, BOUNDS contains the Ritz estimates associated with -c the eigenvalues held in RITZ. This is equal to RNORM -c times the last components of the eigenvectors corresponding -c to the eigenvalues in RITZ. -c -c Q Complex*16 N by N array. (WORKSPACE) -c Workspace needed to store the eigenvectors of H. -c -c LDQ Integer. (INPUT) -c Leading dimension of Q exactly as declared in the calling -c program. -c -c WORKL Complex*16 work array of length N**2 + 3*N. (WORKSPACE) -c Private (replicated) array on each PE or array allocated on -c the front end. This is needed to keep the full Schur form -c of H and also in the calculation of the eigenvectors of H. -c -c RWORK Double precision work array of length N (WORKSPACE) -c Private (replicated) array on each PE or array allocated on -c the front end. -c -c IERR Integer. (OUTPUT) -c Error exit flag from zlahqr or ztrevc. -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Local variables: -c xxxxxx Complex*16 -c -c\Routines called: -c ivout ARPACK utility routine that prints integers. -c arscnd ARPACK utility routine for timing. -c zmout ARPACK utility routine that prints matrices -c zvout ARPACK utility routine that prints vectors. -c dvout ARPACK utility routine that prints vectors. -c zlacpy LAPACK matrix copy routine. -c zlahqr LAPACK routine to compute the Schur form of an -c upper Hessenberg matrix. -c zlaset LAPACK matrix initialization routine. -c ztrevc LAPACK routine to compute the eigenvectors of a matrix -c in upper triangular form -c zcopy Level 1 BLAS that copies one vector to another. -c zdscal Level 1 BLAS that scales a complex vector by a real number. -c dznrm2 Level 1 BLAS that computes the norm of a vector. -c -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\SCCS Information: @(#) -c FILE: neigh.F SID: 2.2 DATE OF SID: 4/20/96 RELEASE: 2 -c -c\Remarks -c None -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine zneigh (rnorm, n, h, ldh, ritz, bounds, - & q, ldq, workl, rwork, ierr) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - integer ierr, n, ldh, ldq - Double precision - & rnorm -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - Complex*16 - & bounds(n), h(ldh,n), q(ldq,n), ritz(n), - & workl(n*(n+3)) - Double precision - & rwork(n) -c -c %------------% -c | Parameters | -c %------------% -c - Complex*16 - & one, zero - Double precision - & rone - parameter (one = (1.0D+0, 0.0D+0), zero = (0.0D+0, 0.0D+0), - & rone = 1.0D+0) -c -c %------------------------% -c | Local Scalars & Arrays | -c %------------------------% -c - logical select(1) - integer j, msglvl - Complex*16 - & vl(1) - Double precision - & temp -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external zlacpy, zlahqr, ztrevc, zcopy, - & zdscal, zmout, zvout, arscnd -c -c %--------------------% -c | External Functions | -c %--------------------% -c - Double precision - & dznrm2 - external dznrm2 -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c -c %-------------------------------% -c | Initialize timing statistics | -c | & message level for debugging | -c %-------------------------------% -c - call arscnd (t0) - msglvl = mceigh -c - if (msglvl .gt. 2) then - call zmout (logfil, n, n, h, ldh, ndigit, - & '_neigh: Entering upper Hessenberg matrix H ') - end if -c -c %----------------------------------------------------------% -c | 1. Compute the eigenvalues, the last components of the | -c | corresponding Schur vectors and the full Schur form T | -c | of the current upper Hessenberg matrix H. | -c | zlahqr returns the full Schur form of H | -c | in WORKL(1:N**2), and the Schur vectors in q. | -c %----------------------------------------------------------% -c - call zlacpy ('All', n, n, h, ldh, workl, n) - call zlaset ('All', n, n, zero, one, q, ldq) - call zlahqr (.true., .true., n, 1, n, workl, ldh, ritz, - & 1, n, q, ldq, ierr) - if (ierr .ne. 0) go to 9000 -c - call zcopy (n, q(n-1,1), ldq, bounds, 1) - if (msglvl .gt. 1) then - call zvout (logfil, n, bounds, ndigit, - & '_neigh: last row of the Schur matrix for H') - end if -c -c %----------------------------------------------------------% -c | 2. Compute the eigenvectors of the full Schur form T and | -c | apply the Schur vectors to get the corresponding | -c | eigenvectors. | -c %----------------------------------------------------------% -c - call ztrevc ('Right', 'Back', select, n, workl, n, vl, n, q, - & ldq, n, n, workl(n*n+1), rwork, ierr) -c - if (ierr .ne. 0) go to 9000 -c -c %------------------------------------------------% -c | Scale the returning eigenvectors so that their | -c | Euclidean norms are all one. LAPACK subroutine | -c | ztrevc returns each eigenvector normalized so | -c | that the element of largest magnitude has | -c | magnitude 1; here the magnitude of a complex | -c | number (x,y) is taken to be |x| + |y|. | -c %------------------------------------------------% -c - do 10 j=1, n - temp = dznrm2( n, q(1,j), 1 ) - call zdscal ( n, rone / temp, q(1,j), 1 ) - 10 continue -c - if (msglvl .gt. 1) then - call zcopy(n, q(n,1), ldq, workl, 1) - call zvout (logfil, n, workl, ndigit, - & '_neigh: Last row of the eigenvector matrix for H') - end if -c -c %----------------------------% -c | Compute the Ritz estimates | -c %----------------------------% -c - call zcopy(n, q(n,1), n, bounds, 1) - call zdscal(n, rnorm, bounds, 1) -c - if (msglvl .gt. 2) then - call zvout (logfil, n, ritz, ndigit, - & '_neigh: The eigenvalues of H') - call zvout (logfil, n, bounds, ndigit, - & '_neigh: Ritz estimates for the eigenvalues of H') - end if -c - call arscnd(t1) - tceigh = tceigh + (t1 - t0) -c - 9000 continue - return -c -c %---------------% -c | End of zneigh | -c %---------------% -c - end
--- a/libcruft/arpack/src/zneupd.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,876 +0,0 @@ -c\BeginDoc -c -c\Name: zneupd -c -c\Description: -c This subroutine returns the converged approximations to eigenvalues -c of A*z = lambda*B*z and (optionally): -c -c (1) The corresponding approximate eigenvectors; -c -c (2) An orthonormal basis for the associated approximate -c invariant subspace; -c -c (3) Both. -c -c There is negligible additional cost to obtain eigenvectors. An orthonormal -c basis is always computed. There is an additional storage cost of n*nev -c if both are requested (in this case a separate array Z must be supplied). -c -c The approximate eigenvalues and eigenvectors of A*z = lambda*B*z -c are derived from approximate eigenvalues and eigenvectors of -c of the linear operator OP prescribed by the MODE selection in the -c call to ZNAUPD . ZNAUPD must be called before this routine is called. -c These approximate eigenvalues and vectors are commonly called Ritz -c values and Ritz vectors respectively. They are referred to as such -c in the comments that follow. The computed orthonormal basis for the -c invariant subspace corresponding to these Ritz values is referred to as a -c Schur basis. -c -c The definition of OP as well as other terms and the relation of computed -c Ritz values and vectors of OP with respect to the given problem -c A*z = lambda*B*z may be found in the header of ZNAUPD . For a brief -c description, see definitions of IPARAM(7), MODE and WHICH in the -c documentation of ZNAUPD . -c -c\Usage: -c call zneupd -c ( RVEC, HOWMNY, SELECT, D, Z, LDZ, SIGMA, WORKEV, BMAT, -c N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, WORKD, -c WORKL, LWORKL, RWORK, INFO ) -c -c\Arguments: -c RVEC LOGICAL (INPUT) -c Specifies whether a basis for the invariant subspace corresponding -c to the converged Ritz value approximations for the eigenproblem -c A*z = lambda*B*z is computed. -c -c RVEC = .FALSE. Compute Ritz values only. -c -c RVEC = .TRUE. Compute Ritz vectors or Schur vectors. -c See Remarks below. -c -c HOWMNY Character*1 (INPUT) -c Specifies the form of the basis for the invariant subspace -c corresponding to the converged Ritz values that is to be computed. -c -c = 'A': Compute NEV Ritz vectors; -c = 'P': Compute NEV Schur vectors; -c = 'S': compute some of the Ritz vectors, specified -c by the logical array SELECT. -c -c SELECT Logical array of dimension NCV. (INPUT) -c If HOWMNY = 'S', SELECT specifies the Ritz vectors to be -c computed. To select the Ritz vector corresponding to a -c Ritz value D(j), SELECT(j) must be set to .TRUE.. -c If HOWMNY = 'A' or 'P', SELECT need not be initialized -c but it is used as internal workspace. -c -c D Complex*16 array of dimension NEV+1. (OUTPUT) -c On exit, D contains the Ritz approximations -c to the eigenvalues lambda for A*z = lambda*B*z. -c -c Z Complex*16 N by NEV array (OUTPUT) -c On exit, if RVEC = .TRUE. and HOWMNY = 'A', then the columns of -c Z represents approximate eigenvectors (Ritz vectors) corresponding -c to the NCONV=IPARAM(5) Ritz values for eigensystem -c A*z = lambda*B*z. -c -c If RVEC = .FALSE. or HOWMNY = 'P', then Z is NOT REFERENCED. -c -c NOTE: If if RVEC = .TRUE. and a Schur basis is not required, -c the array Z may be set equal to first NEV+1 columns of the Arnoldi -c basis array V computed by ZNAUPD . In this case the Arnoldi basis -c will be destroyed and overwritten with the eigenvector basis. -c -c LDZ Integer. (INPUT) -c The leading dimension of the array Z. If Ritz vectors are -c desired, then LDZ .ge. max( 1, N ) is required. -c In any case, LDZ .ge. 1 is required. -c -c SIGMA Complex*16 (INPUT) -c If IPARAM(7) = 3 then SIGMA represents the shift. -c Not referenced if IPARAM(7) = 1 or 2. -c -c WORKEV Complex*16 work array of dimension 2*NCV. (WORKSPACE) -c -c **** The remaining arguments MUST be the same as for the **** -c **** call to ZNAUPD that was just completed. **** -c -c NOTE: The remaining arguments -c -c BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, -c WORKD, WORKL, LWORKL, RWORK, INFO -c -c must be passed directly to ZNEUPD following the last call -c to ZNAUPD . These arguments MUST NOT BE MODIFIED between -c the the last call to ZNAUPD and the call to ZNEUPD . -c -c Three of these parameters (V, WORKL and INFO) are also output parameters: -c -c V Complex*16 N by NCV array. (INPUT/OUTPUT) -c -c Upon INPUT: the NCV columns of V contain the Arnoldi basis -c vectors for OP as constructed by ZNAUPD . -c -c Upon OUTPUT: If RVEC = .TRUE. the first NCONV=IPARAM(5) columns -c contain approximate Schur vectors that span the -c desired invariant subspace. -c -c NOTE: If the array Z has been set equal to first NEV+1 columns -c of the array V and RVEC=.TRUE. and HOWMNY= 'A', then the -c Arnoldi basis held by V has been overwritten by the desired -c Ritz vectors. If a separate array Z has been passed then -c the first NCONV=IPARAM(5) columns of V will contain approximate -c Schur vectors that span the desired invariant subspace. -c -c WORKL Double precision work array of length LWORKL. (OUTPUT/WORKSPACE) -c WORKL(1:ncv*ncv+2*ncv) contains information obtained in -c znaupd . They are not changed by zneupd . -c WORKL(ncv*ncv+2*ncv+1:3*ncv*ncv+4*ncv) holds the -c untransformed Ritz values, the untransformed error estimates of -c the Ritz values, the upper triangular matrix for H, and the -c associated matrix representation of the invariant subspace for H. -c -c Note: IPNTR(9:13) contains the pointer into WORKL for addresses -c of the above information computed by zneupd . -c ------------------------------------------------------------- -c IPNTR(9): pointer to the NCV RITZ values of the -c original system. -c IPNTR(10): Not used -c IPNTR(11): pointer to the NCV corresponding error estimates. -c IPNTR(12): pointer to the NCV by NCV upper triangular -c Schur matrix for H. -c IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors -c of the upper Hessenberg matrix H. Only referenced by -c zneupd if RVEC = .TRUE. See Remark 2 below. -c ------------------------------------------------------------- -c -c INFO Integer. (OUTPUT) -c Error flag on output. -c = 0: Normal exit. -c -c = 1: The Schur form computed by LAPACK routine csheqr -c could not be reordered by LAPACK routine ztrsen . -c Re-enter subroutine zneupd with IPARAM(5)=NCV and -c increase the size of the array D to have -c dimension at least dimension NCV and allocate at least NCV -c columns for Z. NOTE: Not necessary if Z and V share -c the same space. Please notify the authors if this error -c occurs. -c -c = -1: N must be positive. -c = -2: NEV must be positive. -c = -3: NCV-NEV >= 2 and less than or equal to N. -c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI' -c = -6: BMAT must be one of 'I' or 'G'. -c = -7: Length of private work WORKL array is not sufficient. -c = -8: Error return from LAPACK eigenvalue calculation. -c This should never happened. -c = -9: Error return from calculation of eigenvectors. -c Informational error from LAPACK routine ztrevc . -c = -10: IPARAM(7) must be 1,2,3 -c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. -c = -12: HOWMNY = 'S' not yet implemented -c = -13: HOWMNY must be one of 'A' or 'P' if RVEC = .true. -c = -14: ZNAUPD did not find any eigenvalues to sufficient -c accuracy. -c = -15: ZNEUPD got a different count of the number of converged -c Ritz values than ZNAUPD got. This indicates the user -c probably made an error in passing data from ZNAUPD to -c ZNEUPD or that the data was modified before entering -c ZNEUPD -c -c\BeginLib -c -c\References: -c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in -c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), -c pp 357-385. -c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly -c Restarted Arnoldi Iteration", Rice University Technical Report -c TR95-13, Department of Computational and Applied Mathematics. -c 3. B. Nour-Omid, B. N. Parlett, T. Ericsson and P. S. Jensen, -c "How to Implement the Spectral Transformation", Math Comp., -c Vol. 48, No. 178, April, 1987 pp. 664-673. -c -c\Routines called: -c ivout ARPACK utility routine that prints integers. -c zmout ARPACK utility routine that prints matrices -c zvout ARPACK utility routine that prints vectors. -c zgeqr2 LAPACK routine that computes the QR factorization of -c a matrix. -c zlacpy LAPACK matrix copy routine. -c zlahqr LAPACK routine that computes the Schur form of a -c upper Hessenberg matrix. -c zlaset LAPACK matrix initialization routine. -c ztrevc LAPACK routine to compute the eigenvectors of a matrix -c in upper triangular form. -c ztrsen LAPACK routine that re-orders the Schur form. -c zunm2r LAPACK routine that applies an orthogonal matrix in -c factored form. -c dlamch LAPACK routine that determines machine constants. -c ztrmm Level 3 BLAS matrix times an upper triangular matrix. -c zgeru Level 2 BLAS rank one update to a matrix. -c zcopy Level 1 BLAS that copies one vector to another . -c zscal Level 1 BLAS that scales a vector. -c zdscal Level 1 BLAS that scales a complex vector by a real number. -c dznrm2 Level 1 BLAS that computes the norm of a complex vector. -c -c\Remarks -c -c 1. Currently only HOWMNY = 'A' and 'P' are implemented. -c -c 2. Schur vectors are an orthogonal representation for the basis of -c Ritz vectors. Thus, their numerical properties are often superior. -c If RVEC = .true. then the relationship -c A * V(:,1:IPARAM(5)) = V(:,1:IPARAM(5)) * T, and -c transpose( V(:,1:IPARAM(5)) ) * V(:,1:IPARAM(5)) = I -c are approximately satisfied. -c Here T is the leading submatrix of order IPARAM(5) of the -c upper triangular matrix stored workl(ipntr(12)). -c -c\Authors -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Chao Yang Houston, Texas -c Dept. of Computational & -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\SCCS Information: @(#) -c FILE: neupd.F SID: 2.7 DATE OF SID: 09/20/00 RELEASE: 2 -c -c\EndLib -c -c----------------------------------------------------------------------- - subroutine zneupd (rvec , howmny, select, d , - & z , ldz , sigma , workev, - & bmat , n , which , nev , - & tol , resid , ncv , v , - & ldv , iparam, ipntr , workd , - & workl, lworkl, rwork , info ) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - character bmat, howmny, which*2 - logical rvec - integer info, ldz, ldv, lworkl, n, ncv, nev - Complex*16 - & sigma - Double precision - & tol -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - integer iparam(11), ipntr(14) - logical select(ncv) - Double precision - & rwork(ncv) - Complex*16 - & d(nev) , resid(n) , v(ldv,ncv), - & z(ldz, nev), - & workd(3*n) , workl(lworkl), workev(2*ncv) -c -c %------------% -c | Parameters | -c %------------% -c - Complex*16 - & one, zero - parameter (one = (1.0D+0, 0.0D+0) , zero = (0.0D+0, 0.0D+0) ) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - character type*6 - integer bounds, ierr , ih , ihbds, iheig , nconv , - & invsub, iuptri, iwev , j , ldh , ldq , - & mode , msglvl, ritz , wr , k , irz , - & ibd , outncv, iq , np , numcnv, jj , - & ishift, nconv2 - Complex*16 - & rnorm, temp, vl(1) - Double precision - & conds, sep, rtemp, eps23 - logical reord -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external zcopy , zgeru , zgeqr2 , zlacpy , zmout , - & zunm2r , ztrmm , zvout , ivout, - & zlahqr -c -c %--------------------% -c | External Functions | -c %--------------------% -c - Double precision - & dznrm2 , dlamch , dlapy2 - external dznrm2 , dlamch , dlapy2 -c - Complex*16 - & zdotc - external zdotc -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c -c %------------------------% -c | Set default parameters | -c %------------------------% -c - msglvl = mceupd - mode = iparam(7) - nconv = iparam(5) - info = 0 -c -c -c %---------------------------------% -c | Get machine dependent constant. | -c %---------------------------------% -c - eps23 = dlamch ('Epsilon-Machine') - eps23 = eps23**(2.0D+0 / 3.0D+0 ) -c -c %-------------------------------% -c | Quick return | -c | Check for incompatible input | -c %-------------------------------% -c - ierr = 0 -c - if (nconv .le. 0) then - ierr = -14 - else if (n .le. 0) then - ierr = -1 - else if (nev .le. 0) then - ierr = -2 - else if (ncv .le. nev+1 .or. ncv .gt. n) then - ierr = -3 - else if (which .ne. 'LM' .and. - & which .ne. 'SM' .and. - & which .ne. 'LR' .and. - & which .ne. 'SR' .and. - & which .ne. 'LI' .and. - & which .ne. 'SI') then - ierr = -5 - else if (bmat .ne. 'I' .and. bmat .ne. 'G') then - ierr = -6 - else if (lworkl .lt. 3*ncv**2 + 4*ncv) then - ierr = -7 - else if ( (howmny .ne. 'A' .and. - & howmny .ne. 'P' .and. - & howmny .ne. 'S') .and. rvec ) then - ierr = -13 - else if (howmny .eq. 'S' ) then - ierr = -12 - end if -c - if (mode .eq. 1 .or. mode .eq. 2) then - type = 'REGULR' - else if (mode .eq. 3 ) then - type = 'SHIFTI' - else - ierr = -10 - end if - if (mode .eq. 1 .and. bmat .eq. 'G') ierr = -11 -c -c %------------% -c | Error Exit | -c %------------% -c - if (ierr .ne. 0) then - info = ierr - go to 9000 - end if -c -c %--------------------------------------------------------% -c | Pointer into WORKL for address of H, RITZ, WORKEV, Q | -c | etc... and the remaining workspace. | -c | Also update pointer to be used on output. | -c | Memory is laid out as follows: | -c | workl(1:ncv*ncv) := generated Hessenberg matrix | -c | workl(ncv*ncv+1:ncv*ncv+ncv) := ritz values | -c | workl(ncv*ncv+ncv+1:ncv*ncv+2*ncv) := error bounds | -c %--------------------------------------------------------% -c -c %-----------------------------------------------------------% -c | The following is used and set by ZNEUPD . | -c | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := The untransformed | -c | Ritz values. | -c | workl(ncv*ncv+3*ncv+1:ncv*ncv+4*ncv) := The untransformed | -c | error bounds of | -c | the Ritz values | -c | workl(ncv*ncv+4*ncv+1:2*ncv*ncv+4*ncv) := Holds the upper | -c | triangular matrix | -c | for H. | -c | workl(2*ncv*ncv+4*ncv+1: 3*ncv*ncv+4*ncv) := Holds the | -c | associated matrix | -c | representation of | -c | the invariant | -c | subspace for H. | -c | GRAND total of NCV * ( 3 * NCV + 4 ) locations. | -c %-----------------------------------------------------------% -c - ih = ipntr(5) - ritz = ipntr(6) - iq = ipntr(7) - bounds = ipntr(8) - ldh = ncv - ldq = ncv - iheig = bounds + ldh - ihbds = iheig + ldh - iuptri = ihbds + ldh - invsub = iuptri + ldh*ncv - ipntr(9) = iheig - ipntr(11) = ihbds - ipntr(12) = iuptri - ipntr(13) = invsub - wr = 1 - iwev = wr + ncv -c -c %-----------------------------------------% -c | irz points to the Ritz values computed | -c | by _neigh before exiting _naup2. | -c | ibd points to the Ritz estimates | -c | computed by _neigh before exiting | -c | _naup2. | -c %-----------------------------------------% -c - irz = ipntr(14) + ncv*ncv - ibd = irz + ncv -c -c %------------------------------------% -c | RNORM is B-norm of the RESID(1:N). | -c %------------------------------------% -c - rnorm = workl(ih+2) - workl(ih+2) = zero -c - if (msglvl .gt. 2) then - call zvout (logfil, ncv, workl(irz), ndigit, - & '_neupd: Ritz values passed in from _NAUPD.') - call zvout (logfil, ncv, workl(ibd), ndigit, - & '_neupd: Ritz estimates passed in from _NAUPD.') - end if -c - if (rvec) then -c - reord = .false. -c -c %---------------------------------------------------% -c | Use the temporary bounds array to store indices | -c | These will be used to mark the select array later | -c %---------------------------------------------------% -c - do 10 j = 1,ncv - workl(bounds+j-1) = j - select(j) = .false. - 10 continue -c -c %-------------------------------------% -c | Select the wanted Ritz values. | -c | Sort the Ritz values so that the | -c | wanted ones appear at the tailing | -c | NEV positions of workl(irr) and | -c | workl(iri). Move the corresponding | -c | error estimates in workl(ibd) | -c | accordingly. | -c %-------------------------------------% -c - np = ncv - nev - ishift = 0 - call zngets (ishift, which , nev , - & np , workl(irz), workl(bounds)) -c - if (msglvl .gt. 2) then - call zvout (logfil, ncv, workl(irz), ndigit, - & '_neupd: Ritz values after calling _NGETS.') - call zvout (logfil, ncv, workl(bounds), ndigit, - & '_neupd: Ritz value indices after calling _NGETS.') - end if -c -c %-----------------------------------------------------% -c | Record indices of the converged wanted Ritz values | -c | Mark the select array for possible reordering | -c %-----------------------------------------------------% -c - numcnv = 0 - do 11 j = 1,ncv - rtemp = max(eps23, - & dlapy2 ( dble (workl(irz+ncv-j)), - & dimag (workl(irz+ncv-j)) )) - jj = workl(bounds + ncv - j) - if (numcnv .lt. nconv .and. - & dlapy2 ( dble (workl(ibd+jj-1)), - & dimag (workl(ibd+jj-1)) ) - & .le. tol*rtemp) then - select(jj) = .true. - numcnv = numcnv + 1 - if (jj .gt. nev) reord = .true. - endif - 11 continue -c -c %-----------------------------------------------------------% -c | Check the count (numcnv) of converged Ritz values with | -c | the number (nconv) reported by dnaupd. If these two | -c | are different then there has probably been an error | -c | caused by incorrect passing of the dnaupd data. | -c %-----------------------------------------------------------% -c - if (msglvl .gt. 2) then - call ivout(logfil, 1, numcnv, ndigit, - & '_neupd: Number of specified eigenvalues') - call ivout(logfil, 1, nconv, ndigit, - & '_neupd: Number of "converged" eigenvalues') - end if -c - if (numcnv .ne. nconv) then - info = -15 - go to 9000 - end if -c -c %-------------------------------------------------------% -c | Call LAPACK routine zlahqr to compute the Schur form | -c | of the upper Hessenberg matrix returned by ZNAUPD . | -c | Make a copy of the upper Hessenberg matrix. | -c | Initialize the Schur vector matrix Q to the identity. | -c %-------------------------------------------------------% -c - call zcopy (ldh*ncv, workl(ih), 1, workl(iuptri), 1) - call zlaset ('All', ncv, ncv , - & zero , one, workl(invsub), - & ldq) - call zlahqr (.true., .true. , ncv , - & 1 , ncv , workl(iuptri), - & ldh , workl(iheig) , 1 , - & ncv , workl(invsub), ldq , - & ierr) - call zcopy (ncv , workl(invsub+ncv-1), ldq, - & workl(ihbds), 1) -c - if (ierr .ne. 0) then - info = -8 - go to 9000 - end if -c - if (msglvl .gt. 1) then - call zvout (logfil, ncv, workl(iheig), ndigit, - & '_neupd: Eigenvalues of H') - call zvout (logfil, ncv, workl(ihbds), ndigit, - & '_neupd: Last row of the Schur vector matrix') - if (msglvl .gt. 3) then - call zmout (logfil , ncv, ncv , - & workl(iuptri), ldh, ndigit, - & '_neupd: The upper triangular matrix ') - end if - end if -c - if (reord) then -c -c %-----------------------------------------------% -c | Reorder the computed upper triangular matrix. | -c %-----------------------------------------------% -c - call ztrsen ('None' , 'V' , select , - & ncv , workl(iuptri), ldh , - & workl(invsub), ldq , workl(iheig), - & nconv2 , conds , sep , - & workev , ncv , ierr) -c - if (nconv2 .lt. nconv) then - nconv = nconv2 - end if - - if (ierr .eq. 1) then - info = 1 - go to 9000 - end if -c - if (msglvl .gt. 2) then - call zvout (logfil, ncv, workl(iheig), ndigit, - & '_neupd: Eigenvalues of H--reordered') - if (msglvl .gt. 3) then - call zmout (logfil , ncv, ncv , - & workl(iuptri), ldq, ndigit, - & '_neupd: Triangular matrix after re-ordering') - end if - end if -c - end if -c -c %---------------------------------------------% -c | Copy the last row of the Schur basis matrix | -c | to workl(ihbds). This vector will be used | -c | to compute the Ritz estimates of converged | -c | Ritz values. | -c %---------------------------------------------% -c - call zcopy (ncv , workl(invsub+ncv-1), ldq, - & workl(ihbds), 1) -c -c %--------------------------------------------% -c | Place the computed eigenvalues of H into D | -c | if a spectral transformation was not used. | -c %--------------------------------------------% -c - if (type .eq. 'REGULR') then - call zcopy (nconv, workl(iheig), 1, d, 1) - end if -c -c %----------------------------------------------------------% -c | Compute the QR factorization of the matrix representing | -c | the wanted invariant subspace located in the first NCONV | -c | columns of workl(invsub,ldq). | -c %----------------------------------------------------------% -c - call zgeqr2 (ncv , nconv , workl(invsub), - & ldq , workev, workev(ncv+1), - & ierr) -c -c %--------------------------------------------------------% -c | * Postmultiply V by Q using zunm2r . | -c | * Copy the first NCONV columns of VQ into Z. | -c | * Postmultiply Z by R. | -c | The N by NCONV matrix Z is now a matrix representation | -c | of the approximate invariant subspace associated with | -c | the Ritz values in workl(iheig). The first NCONV | -c | columns of V are now approximate Schur vectors | -c | associated with the upper triangular matrix of order | -c | NCONV in workl(iuptri). | -c %--------------------------------------------------------% -c - call zunm2r ('Right', 'Notranspose', n , - & ncv , nconv , workl(invsub), - & ldq , workev , v , - & ldv , workd(n+1) , ierr) - call zlacpy ('All', n, nconv, v, ldv, z, ldz) -c - do 20 j=1, nconv -c -c %---------------------------------------------------% -c | Perform both a column and row scaling if the | -c | diagonal element of workl(invsub,ldq) is negative | -c | I'm lazy and don't take advantage of the upper | -c | triangular form of workl(iuptri,ldq). | -c | Note that since Q is orthogonal, R is a diagonal | -c | matrix consisting of plus or minus ones. | -c %---------------------------------------------------% -c - if ( dble ( workl(invsub+(j-1)*ldq+j-1) ) .lt. - & dble (zero) ) then - call zscal (nconv, -one, workl(iuptri+j-1), ldq) - call zscal (nconv, -one, workl(iuptri+(j-1)*ldq), 1) - end if -c - 20 continue -c - if (howmny .eq. 'A') then -c -c %--------------------------------------------% -c | Compute the NCONV wanted eigenvectors of T | -c | located in workl(iuptri,ldq). | -c %--------------------------------------------% -c - do 30 j=1, ncv - if (j .le. nconv) then - select(j) = .true. - else - select(j) = .false. - end if - 30 continue -c - call ztrevc ('Right', 'Select' , select , - & ncv , workl(iuptri), ldq , - & vl , 1 , workl(invsub), - & ldq , ncv , outncv , - & workev , rwork , ierr) -c - if (ierr .ne. 0) then - info = -9 - go to 9000 - end if -c -c %------------------------------------------------% -c | Scale the returning eigenvectors so that their | -c | Euclidean norms are all one. LAPACK subroutine | -c | ztrevc returns each eigenvector normalized so | -c | that the element of largest magnitude has | -c | magnitude 1. | -c %------------------------------------------------% -c - do 40 j=1, nconv - rtemp = dznrm2 (ncv, workl(invsub+(j-1)*ldq), 1) - rtemp = dble (one) / rtemp - call zdscal ( ncv, rtemp, - & workl(invsub+(j-1)*ldq), 1 ) -c -c %------------------------------------------% -c | Ritz estimates can be obtained by taking | -c | the inner product of the last row of the | -c | Schur basis of H with eigenvectors of T. | -c | Note that the eigenvector matrix of T is | -c | upper triangular, thus the length of the | -c | inner product can be set to j. | -c %------------------------------------------% -c - workev(j) = zdotc (j, workl(ihbds), 1, - & workl(invsub+(j-1)*ldq), 1) - 40 continue -c - if (msglvl .gt. 2) then - call zcopy (nconv, workl(invsub+ncv-1), ldq, - & workl(ihbds), 1) - call zvout (logfil, nconv, workl(ihbds), ndigit, - & '_neupd: Last row of the eigenvector matrix for T') - if (msglvl .gt. 3) then - call zmout (logfil , ncv, ncv , - & workl(invsub), ldq, ndigit, - & '_neupd: The eigenvector matrix for T') - end if - end if -c -c %---------------------------------------% -c | Copy Ritz estimates into workl(ihbds) | -c %---------------------------------------% -c - call zcopy (nconv, workev, 1, workl(ihbds), 1) -c -c %----------------------------------------------% -c | The eigenvector matrix Q of T is triangular. | -c | Form Z*Q. | -c %----------------------------------------------% -c - call ztrmm ('Right' , 'Upper' , 'No transpose', - & 'Non-unit', n , nconv , - & one , workl(invsub), ldq , - & z , ldz) - end if -c - else -c -c %--------------------------------------------------% -c | An approximate invariant subspace is not needed. | -c | Place the Ritz values computed ZNAUPD into D. | -c %--------------------------------------------------% -c - call zcopy (nconv, workl(ritz), 1, d, 1) - call zcopy (nconv, workl(ritz), 1, workl(iheig), 1) - call zcopy (nconv, workl(bounds), 1, workl(ihbds), 1) -c - end if -c -c %------------------------------------------------% -c | Transform the Ritz values and possibly vectors | -c | and corresponding error bounds of OP to those | -c | of A*x = lambda*B*x. | -c %------------------------------------------------% -c - if (type .eq. 'REGULR') then -c - if (rvec) - & call zscal (ncv, rnorm, workl(ihbds), 1) -c - else -c -c %---------------------------------------% -c | A spectral transformation was used. | -c | * Determine the Ritz estimates of the | -c | Ritz values in the original system. | -c %---------------------------------------% -c - if (rvec) - & call zscal (ncv, rnorm, workl(ihbds), 1) -c - do 50 k=1, ncv - temp = workl(iheig+k-1) - workl(ihbds+k-1) = workl(ihbds+k-1) / temp / temp - 50 continue -c - end if -c -c %-----------------------------------------------------------% -c | * Transform the Ritz values back to the original system. | -c | For TYPE = 'SHIFTI' the transformation is | -c | lambda = 1/theta + sigma | -c | NOTES: | -c | *The Ritz vectors are not affected by the transformation. | -c %-----------------------------------------------------------% -c - if (type .eq. 'SHIFTI') then - do 60 k=1, nconv - d(k) = one / workl(iheig+k-1) + sigma - 60 continue - end if -c - if (type .ne. 'REGULR' .and. msglvl .gt. 1) then - call zvout (logfil, nconv, d, ndigit, - & '_neupd: Untransformed Ritz values.') - call zvout (logfil, nconv, workl(ihbds), ndigit, - & '_neupd: Ritz estimates of the untransformed Ritz values.') - else if ( msglvl .gt. 1) then - call zvout (logfil, nconv, d, ndigit, - & '_neupd: Converged Ritz values.') - call zvout (logfil, nconv, workl(ihbds), ndigit, - & '_neupd: Associated Ritz estimates.') - end if -c -c %-------------------------------------------------% -c | Eigenvector Purification step. Formally perform | -c | one of inverse subspace iteration. Only used | -c | for MODE = 3. See reference 3. | -c %-------------------------------------------------% -c - if (rvec .and. howmny .eq. 'A' .and. type .eq. 'SHIFTI') then -c -c %------------------------------------------------% -c | Purify the computed Ritz vectors by adding a | -c | little bit of the residual vector: | -c | T | -c | resid(:)*( e s ) / theta | -c | NCV | -c | where H s = s theta. | -c %------------------------------------------------% -c - do 100 j=1, nconv - if (workl(iheig+j-1) .ne. zero) then - workev(j) = workl(invsub+(j-1)*ldq+ncv-1) / - & workl(iheig+j-1) - endif - 100 continue - -c %---------------------------------------% -c | Perform a rank one update to Z and | -c | purify all the Ritz vectors together. | -c %---------------------------------------% -c - call zgeru (n, nconv, one, resid, 1, workev, 1, z, ldz) -c - end if -c - 9000 continue -c - return -c -c %---------------% -c | End of zneupd | -c %---------------% -c - end
--- a/libcruft/arpack/src/zngets.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,178 +0,0 @@ -c\BeginDoc -c -c\Name: zngets -c -c\Description: -c Given the eigenvalues of the upper Hessenberg matrix H, -c computes the NP shifts AMU that are zeros of the polynomial of -c degree NP which filters out components of the unwanted eigenvectors -c corresponding to the AMU's based on some given criteria. -c -c NOTE: call this even in the case of user specified shifts in order -c to sort the eigenvalues, and error bounds of H for later use. -c -c\Usage: -c call zngets -c ( ISHIFT, WHICH, KEV, NP, RITZ, BOUNDS ) -c -c\Arguments -c ISHIFT Integer. (INPUT) -c Method for selecting the implicit shifts at each iteration. -c ISHIFT = 0: user specified shifts -c ISHIFT = 1: exact shift with respect to the matrix H. -c -c WHICH Character*2. (INPUT) -c Shift selection criteria. -c 'LM' -> want the KEV eigenvalues of largest magnitude. -c 'SM' -> want the KEV eigenvalues of smallest magnitude. -c 'LR' -> want the KEV eigenvalues of largest REAL part. -c 'SR' -> want the KEV eigenvalues of smallest REAL part. -c 'LI' -> want the KEV eigenvalues of largest imaginary part. -c 'SI' -> want the KEV eigenvalues of smallest imaginary part. -c -c KEV Integer. (INPUT) -c The number of desired eigenvalues. -c -c NP Integer. (INPUT) -c The number of shifts to compute. -c -c RITZ Complex*16 array of length KEV+NP. (INPUT/OUTPUT) -c On INPUT, RITZ contains the the eigenvalues of H. -c On OUTPUT, RITZ are sorted so that the unwanted -c eigenvalues are in the first NP locations and the wanted -c portion is in the last KEV locations. When exact shifts are -c selected, the unwanted part corresponds to the shifts to -c be applied. Also, if ISHIFT .eq. 1, the unwanted eigenvalues -c are further sorted so that the ones with largest Ritz values -c are first. -c -c BOUNDS Complex*16 array of length KEV+NP. (INPUT/OUTPUT) -c Error bounds corresponding to the ordering in RITZ. -c -c -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Local variables: -c xxxxxx Complex*16 -c -c\Routines called: -c zsortc ARPACK sorting routine. -c ivout ARPACK utility routine that prints integers. -c arscnd ARPACK utility routine for timing. -c zvout ARPACK utility routine that prints vectors. -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c\SCCS Information: @(#) -c FILE: ngets.F SID: 2.2 DATE OF SID: 4/20/96 RELEASE: 2 -c -c\Remarks -c 1. This routine does not keep complex conjugate pairs of -c eigenvalues together. -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine zngets ( ishift, which, kev, np, ritz, bounds) -c -c %----------------------------------------------------% -c | Include files for debugging and timing information | -c %----------------------------------------------------% -c - include 'debug.h' - include 'stat.h' -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - character*2 which - integer ishift, kev, np -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - Complex*16 - & bounds(kev+np), ritz(kev+np) -c -c %------------% -c | Parameters | -c %------------% -c - Complex*16 - & one, zero - parameter (one = (1.0D+0, 0.0D+0), zero = (0.0D+0, 0.0D+0)) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - integer msglvl -c -c %----------------------% -c | External Subroutines | -c %----------------------% -c - external zvout, zsortc, arscnd -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c -c %-------------------------------% -c | Initialize timing statistics | -c | & message level for debugging | -c %-------------------------------% -c - call arscnd (t0) - msglvl = mcgets -c - call zsortc (which, .true., kev+np, ritz, bounds) -c - if ( ishift .eq. 1 ) then -c -c %-------------------------------------------------------% -c | Sort the unwanted Ritz values used as shifts so that | -c | the ones with largest Ritz estimates are first | -c | This will tend to minimize the effects of the | -c | forward instability of the iteration when the shifts | -c | are applied in subroutine znapps. | -c | Be careful and use 'SM' since we want to sort BOUNDS! | -c %-------------------------------------------------------% -c - call zsortc ( 'SM', .true., np, bounds, ritz ) -c - end if -c - call arscnd (t1) - tcgets = tcgets + (t1 - t0) -c - if (msglvl .gt. 0) then - call ivout (logfil, 1, kev, ndigit, '_ngets: KEV is') - call ivout (logfil, 1, np, ndigit, '_ngets: NP is') - call zvout (logfil, kev+np, ritz, ndigit, - & '_ngets: Eigenvalues of current H matrix ') - call zvout (logfil, kev+np, bounds, ndigit, - & '_ngets: Ritz estimates of the current KEV+NP Ritz values') - end if -c - return -c -c %---------------% -c | End of zngets | -c %---------------% -c - end
--- a/libcruft/arpack/src/zsortc.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,322 +0,0 @@ -c\BeginDoc -c -c\Name: zsortc -c -c\Description: -c Sorts the Complex*16 array in X into the order -c specified by WHICH and optionally applies the permutation to the -c Double precision array Y. -c -c\Usage: -c call zsortc -c ( WHICH, APPLY, N, X, Y ) -c -c\Arguments -c WHICH Character*2. (Input) -c 'LM' -> sort X into increasing order of magnitude. -c 'SM' -> sort X into decreasing order of magnitude. -c 'LR' -> sort X with real(X) in increasing algebraic order -c 'SR' -> sort X with real(X) in decreasing algebraic order -c 'LI' -> sort X with imag(X) in increasing algebraic order -c 'SI' -> sort X with imag(X) in decreasing algebraic order -c -c APPLY Logical. (Input) -c APPLY = .TRUE. -> apply the sorted order to array Y. -c APPLY = .FALSE. -> do not apply the sorted order to array Y. -c -c N Integer. (INPUT) -c Size of the arrays. -c -c X Complex*16 array of length N. (INPUT/OUTPUT) -c This is the array to be sorted. -c -c Y Complex*16 array of length N. (INPUT/OUTPUT) -c -c\EndDoc -c -c----------------------------------------------------------------------- -c -c\BeginLib -c -c\Routines called: -c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. -c -c\Author -c Danny Sorensen Phuong Vu -c Richard Lehoucq CRPC / Rice University -c Dept. of Computational & Houston, Texas -c Applied Mathematics -c Rice University -c Houston, Texas -c -c Adapted from the sort routine in LANSO. -c -c\SCCS Information: @(#) -c FILE: sortc.F SID: 2.2 DATE OF SID: 4/20/96 RELEASE: 2 -c -c\EndLib -c -c----------------------------------------------------------------------- -c - subroutine zsortc (which, apply, n, x, y) -c -c %------------------% -c | Scalar Arguments | -c %------------------% -c - character*2 which - logical apply - integer n -c -c %-----------------% -c | Array Arguments | -c %-----------------% -c - Complex*16 - & x(0:n-1), y(0:n-1) -c -c %---------------% -c | Local Scalars | -c %---------------% -c - integer i, igap, j - Complex*16 - & temp - Double precision - & temp1, temp2 -c -c %--------------------% -c | External functions | -c %--------------------% -c - Double precision - & dlapy2 -c -c %--------------------% -c | Intrinsic Functions | -c %--------------------% - Intrinsic - & dble, dimag -c -c %-----------------------% -c | Executable Statements | -c %-----------------------% -c - igap = n / 2 -c - if (which .eq. 'LM') then -c -c %--------------------------------------------% -c | Sort X into increasing order of magnitude. | -c %--------------------------------------------% -c - 10 continue - if (igap .eq. 0) go to 9000 -c - do 30 i = igap, n-1 - j = i-igap - 20 continue -c - if (j.lt.0) go to 30 -c - temp1 = dlapy2(dble(x(j)),dimag(x(j))) - temp2 = dlapy2(dble(x(j+igap)),dimag(x(j+igap))) -c - if (temp1.gt.temp2) then - temp = x(j) - x(j) = x(j+igap) - x(j+igap) = temp -c - if (apply) then - temp = y(j) - y(j) = y(j+igap) - y(j+igap) = temp - end if - else - go to 30 - end if - j = j-igap - go to 20 - 30 continue - igap = igap / 2 - go to 10 -c - else if (which .eq. 'SM') then -c -c %--------------------------------------------% -c | Sort X into decreasing order of magnitude. | -c %--------------------------------------------% -c - 40 continue - if (igap .eq. 0) go to 9000 -c - do 60 i = igap, n-1 - j = i-igap - 50 continue -c - if (j .lt. 0) go to 60 -c - temp1 = dlapy2(dble(x(j)),dimag(x(j))) - temp2 = dlapy2(dble(x(j+igap)),dimag(x(j+igap))) -c - if (temp1.lt.temp2) then - temp = x(j) - x(j) = x(j+igap) - x(j+igap) = temp -c - if (apply) then - temp = y(j) - y(j) = y(j+igap) - y(j+igap) = temp - end if - else - go to 60 - endif - j = j-igap - go to 50 - 60 continue - igap = igap / 2 - go to 40 -c - else if (which .eq. 'LR') then -c -c %------------------------------------------------% -c | Sort XREAL into increasing order of algebraic. | -c %------------------------------------------------% -c - 70 continue - if (igap .eq. 0) go to 9000 -c - do 90 i = igap, n-1 - j = i-igap - 80 continue -c - if (j.lt.0) go to 90 -c - if (dble(x(j)).gt.dble(x(j+igap))) then - temp = x(j) - x(j) = x(j+igap) - x(j+igap) = temp -c - if (apply) then - temp = y(j) - y(j) = y(j+igap) - y(j+igap) = temp - end if - else - go to 90 - endif - j = j-igap - go to 80 - 90 continue - igap = igap / 2 - go to 70 -c - else if (which .eq. 'SR') then -c -c %------------------------------------------------% -c | Sort XREAL into decreasing order of algebraic. | -c %------------------------------------------------% -c - 100 continue - if (igap .eq. 0) go to 9000 - do 120 i = igap, n-1 - j = i-igap - 110 continue -c - if (j.lt.0) go to 120 -c - if (dble(x(j)).lt.dble(x(j+igap))) then - temp = x(j) - x(j) = x(j+igap) - x(j+igap) = temp -c - if (apply) then - temp = y(j) - y(j) = y(j+igap) - y(j+igap) = temp - end if - else - go to 120 - endif - j = j-igap - go to 110 - 120 continue - igap = igap / 2 - go to 100 -c - else if (which .eq. 'LI') then -c -c %--------------------------------------------% -c | Sort XIMAG into increasing algebraic order | -c %--------------------------------------------% -c - 130 continue - if (igap .eq. 0) go to 9000 - do 150 i = igap, n-1 - j = i-igap - 140 continue -c - if (j.lt.0) go to 150 -c - if (dimag(x(j)).gt.dimag(x(j+igap))) then - temp = x(j) - x(j) = x(j+igap) - x(j+igap) = temp -c - if (apply) then - temp = y(j) - y(j) = y(j+igap) - y(j+igap) = temp - end if - else - go to 150 - endif - j = j-igap - go to 140 - 150 continue - igap = igap / 2 - go to 130 -c - else if (which .eq. 'SI') then -c -c %---------------------------------------------% -c | Sort XIMAG into decreasing algebraic order | -c %---------------------------------------------% -c - 160 continue - if (igap .eq. 0) go to 9000 - do 180 i = igap, n-1 - j = i-igap - 170 continue -c - if (j.lt.0) go to 180 -c - if (dimag(x(j)).lt.dimag(x(j+igap))) then - temp = x(j) - x(j) = x(j+igap) - x(j+igap) = temp -c - if (apply) then - temp = y(j) - y(j) = y(j+igap) - y(j+igap) = temp - end if - else - go to 180 - endif - j = j-igap - go to 170 - 180 continue - igap = igap / 2 - go to 160 - end if -c - 9000 continue - return -c -c %---------------% -c | End of zsortc | -c %---------------% -c - end
--- a/libcruft/arpack/src/zstatn.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,51 +0,0 @@ -c -c\SCCS Information: @(#) -c FILE: statn.F SID: 2.2 DATE OF SID: 4/20/96 RELEASE: 2 -c -c %---------------------------------------------% -c | Initialize statistic and timing information | -c | for complex nonsymmetric Arnoldi code. | -c %---------------------------------------------% - - subroutine zstatn -c -c %--------------------------------% -c | See stat.doc for documentation | -c %--------------------------------% -c - include 'stat.h' - -c %-----------------------% -c | Executable Statements | -c %-----------------------% - - nopx = 0 - nbx = 0 - nrorth = 0 - nitref = 0 - nrstrt = 0 - - tcaupd = 0.0D+0 - tcaup2 = 0.0D+0 - tcaitr = 0.0D+0 - tceigh = 0.0D+0 - tcgets = 0.0D+0 - tcapps = 0.0D+0 - tcconv = 0.0D+0 - titref = 0.0D+0 - tgetv0 = 0.0D+0 - trvec = 0.0D+0 - -c %----------------------------------------------------% -c | User time including reverse communication overhead | -c %----------------------------------------------------% - tmvopx = 0.0D+0 - tmvbx = 0.0D+0 - - return -c -c %---------------% -c | End of zstatn | -c %---------------% -c - end
--- a/libcruft/arpack/util/cmout.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,250 +0,0 @@ -* -* Routine: CMOUT -* -* Purpose: Complex matrix output routine. -* -* Usage: CALL CMOUT (LOUT, M, N, A, LDA, IDIGIT, IFMT) -* -* Arguments -* M - Number of rows of A. (Input) -* N - Number of columns of A. (Input) -* A - Complex M by N matrix to be printed. (Input) -* LDA - Leading dimension of A exactly as specified in the -* dimension statement of the calling program. (Input) -* IFMT - Format to be used in printing matrix A. (Input) -* IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In) -* If IDIGIT .LT. 0, printing is done with 72 columns. -* If IDIGIT .GT. 0, printing is done with 132 columns. -* -*\SCCS Information: @(#) -* FILE: cmout.f SID: 2.1 DATE OF SID: 11/16/95 RELEASE: 2 -* -*----------------------------------------------------------------------- -* - SUBROUTINE CMOUT( LOUT, M, N, A, LDA, IDIGIT, IFMT ) -* ... -* ... SPECIFICATIONS FOR ARGUMENTS - INTEGER M, N, IDIGIT, LDA, LOUT - Complex - & A( LDA, * ) - CHARACTER IFMT*( * ) -* ... -* ... SPECIFICATIONS FOR LOCAL VARIABLES - INTEGER I, J, NDIGIT, K1, K2, LLL - CHARACTER*1 ICOL( 3 ) - CHARACTER*80 LINE -* ... -* ... SPECIFICATIONS INTRINSICS - INTRINSIC MIN -* - DATA ICOL( 1 ), ICOL( 2 ), ICOL( 3 ) / 'C', 'o', - $ 'l' / -* ... -* ... FIRST EXECUTABLE STATEMENT -* - LLL = MIN( LEN( IFMT ), 80 ) - DO 10 I = 1, LLL - LINE( I: I ) = '-' - 10 CONTINUE -* - DO 20 I = LLL + 1, 80 - LINE( I: I ) = ' ' - 20 CONTINUE -* - WRITE( LOUT, 9999 )IFMT, LINE( 1: LLL ) - 9999 FORMAT( / 1X, A / 1X, A ) -* - IF( M.LE.0 .OR. N.LE.0 .OR. LDA.LE.0 ) - $ RETURN - NDIGIT = IDIGIT - IF( IDIGIT.EQ.0 ) - $ NDIGIT = 4 -* -*======================================================================= -* CODE FOR OUTPUT USING 72 COLUMNS FORMAT -*======================================================================= -* - IF( IDIGIT.LT.0 ) THEN - NDIGIT = -IDIGIT - IF( NDIGIT.LE.4 ) THEN - DO 40 K1 = 1, N, 2 - K2 = MIN0( N, K1+1 ) - WRITE( LOUT, 9998 )( ICOL, I, I = K1, K2 ) - DO 30 I = 1, M - IF (K1.NE.N) THEN - WRITE( LOUT, 9994 )I, ( A( I, J ), J = K1, K2 ) - ELSE - WRITE( LOUT, 9984 )I, ( A( I, J ), J = K1, K2 ) - END IF - 30 CONTINUE - 40 CONTINUE -* - ELSE IF( NDIGIT.LE.6 ) THEN - DO 60 K1 = 1, N, 2 - K2 = MIN0( N, K1+1 ) - WRITE( LOUT, 9997 )( ICOL, I, I = K1, K2 ) - DO 50 I = 1, M - IF (K1.NE.N) THEN - WRITE( LOUT, 9993 )I, ( A( I, J ), J = K1, K2 ) - ELSE - WRITE( LOUT, 9983 )I, ( A( I, J ), J = K1, K2 ) - END IF - 50 CONTINUE - 60 CONTINUE -* - ELSE IF( NDIGIT.LE.8 ) THEN - DO 80 K1 = 1, N, 2 - K2 = MIN0( N, K1+1 ) - WRITE( LOUT, 9996 )( ICOL, I, I = K1, K2 ) - DO 70 I = 1, M - IF (K1.NE.N) THEN - WRITE( LOUT, 9992 )I, ( A( I, J ), J = K1, K2 ) - ELSE - WRITE( LOUT, 9982 )I, ( A( I, J ), J = K1, K2 ) - END IF - 70 CONTINUE - 80 CONTINUE -* - ELSE - DO 100 K1 = 1, N - WRITE( LOUT, 9995 ) ICOL, K1 - DO 90 I = 1, M - WRITE( LOUT, 9991 )I, A( I, K1 ) - 90 CONTINUE - 100 CONTINUE - END IF -* -*======================================================================= -* CODE FOR OUTPUT USING 132 COLUMNS FORMAT -*======================================================================= -* - ELSE - IF( NDIGIT.LE.4 ) THEN - DO 120 K1 = 1, N, 4 - K2 = MIN0( N, K1+3 ) - WRITE( LOUT, 9998 )( ICOL, I, I = K1, K2 ) - DO 110 I = 1, M - IF ((K1+3).LE.N) THEN - WRITE( LOUT, 9974 )I, ( A( I, J ), J = K1, K2 ) - ELSE IF ((K1+3-N).EQ.1) THEN - WRITE( LOUT, 9964 )I, ( A( I, J ), J = k1, K2 ) - ELSE IF ((K1+3-N).EQ.2) THEN - WRITE( LOUT, 9954 )I, ( A( I, J ), J = K1, K2 ) - ELSE IF ((K1+3-N).EQ.3) THEN - WRITE( LOUT, 9944 )I, ( A( I, J ), J = K1, K2 ) - END IF - 110 CONTINUE - 120 CONTINUE -* - ELSE IF( NDIGIT.LE.6 ) THEN - DO 140 K1 = 1, N, 3 - K2 = MIN0( N, K1+ 2) - WRITE( LOUT, 9997 )( ICOL, I, I = K1, K2 ) - DO 130 I = 1, M - IF ((K1+2).LE.N) THEN - WRITE( LOUT, 9973 )I, ( A( I, J ), J = K1, K2 ) - ELSE IF ((K1+2-N).EQ.1) THEN - WRITE( LOUT, 9963 )I, ( A( I, J ), J = K1, K2 ) - ELSE IF ((K1+2-N).EQ.2) THEN - WRITE( LOUT, 9953 )I, ( A( I, J ), J = K1, K2 ) - END IF - 130 CONTINUE - 140 CONTINUE -* - ELSE IF( NDIGIT.LE.8 ) THEN - DO 160 K1 = 1, N, 3 - K2 = MIN0( N, K1+2 ) - WRITE( LOUT, 9996 )( ICOL, I, I = K1, K2 ) - DO 150 I = 1, M - IF ((K1+2).LE.N) THEN - WRITE( LOUT, 9972 )I, ( A( I, J ), J = K1, K2 ) - ELSE IF ((K1+2-N).EQ.1) THEN - WRITE( LOUT, 9962 )I, ( A( I, J ), J = K1, K2 ) - ELSE IF ((K1+2-N).EQ.2) THEN - WRITE( LOUT, 9952 )I, ( A( I, J ), J = K1, K2 ) - END IF - 150 CONTINUE - 160 CONTINUE -* - ELSE - DO 180 K1 = 1, N, 2 - K2 = MIN0( N, K1+1 ) - WRITE( LOUT, 9995 )( ICOL, I, I = K1, K2 ) - DO 170 I = 1, M - IF ((K1+1).LE.N) THEN - WRITE( LOUT, 9971 )I, ( A( I, J ), J = K1, K2 ) - ELSE - WRITE( LOUT, 9961 )I, ( A( I, J ), J = K1, K2 ) - END IF - 170 CONTINUE - 180 CONTINUE - END IF - END IF - WRITE( LOUT, 9990 ) -* - 9998 FORMAT( 11X, 4( 9X, 3A1, I4, 9X ) ) - 9997 FORMAT( 10X, 4( 11X, 3A1, I4, 11X ) ) - 9996 FORMAT( 10X, 3( 13X, 3A1, I4, 13X ) ) - 9995 FORMAT( 12X, 2( 18x, 3A1, I4, 18X ) ) -* -*======================================================== -* FORMAT FOR 72 COLUMN -*======================================================== -* -* DISPLAY 4 SIGNIFICANT DIGITS -* - 9994 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',E10.3,',',E10.3,') ') ) - 9984 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',E10.3,',',E10.3,') ') ) -* -* DISPLAY 6 SIGNIFICANT DIGITS -* - 9993 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',E12.5,',',E12.5,') ') ) - 9983 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',E12.5,',',E12.5,') ') ) -* -* DISPLAY 8 SIGNIFICANT DIGITS -* - 9992 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',E14.7,',',E14.7,') ') ) - 9982 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',E14.7,',',E14.7,') ') ) -* -* DISPLAY 13 SIGNIFICANT DIGITS -* - 9991 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',E20.13,',',E20.13,')') ) - 9990 FORMAT( 1X, ' ' ) -* -* -*======================================================== -* FORMAT FOR 132 COLUMN -*======================================================== -* -* DISPLAY 4 SIGNIFICANT DIGIT -* - 9974 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,4('(',E10.3,',',E10.3,') ') ) - 9964 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,3('(',E10.3,',',E10.3,') ') ) - 9954 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',E10.3,',',E10.3,') ') ) - 9944 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',E10.3,',',E10.3,') ') ) -* -* DISPLAY 6 SIGNIFICANT DIGIT -* - 9973 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,3('(',E12.5,',',E12.5,') ') ) - 9963 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',E12.5,',',E12.5,') ') ) - 9953 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',E12.5,',',E12.5,') ') ) -* -* DISPLAY 8 SIGNIFICANT DIGIT -* - 9972 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,3('(',E14.7,',',E14.7,') ') ) - 9962 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',E14.7,',',E14.7,') ') ) - 9952 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',E14.7,',',E14.7,') ') ) -* -* DISPLAY 13 SIGNIFICANT DIGIT -* - 9971 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',E20.13,',',E20.13, - & ') ')) - 9961 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',E20.13,',',E20.13, - & ') ')) - -* -* -* -* - RETURN - END
--- a/libcruft/arpack/util/cvout.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,240 +0,0 @@ -c----------------------------------------------------------------------- -c -c\SCCS Information: @(#) -c FILE: cvout.f SID: 2.1 DATE OF SID: 11/16/95 RELEASE: 2 -c -*----------------------------------------------------------------------- -* Routine: CVOUT -* -* Purpose: Complex vector output routine. -* -* Usage: CALL CVOUT (LOUT, N, CX, IDIGIT, IFMT) -* -* Arguments -* N - Length of array CX. (Input) -* CX - Complex array to be printed. (Input) -* IFMT - Format to be used in printing array CX. (Input) -* IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In) -* If IDIGIT .LT. 0, printing is done with 72 columns. -* If IDIGIT .GT. 0, printing is done with 132 columns. -* -*----------------------------------------------------------------------- -* - SUBROUTINE CVOUT( LOUT, N, CX, IDIGIT, IFMT ) -* ... -* ... SPECIFICATIONS FOR ARGUMENTS - INTEGER N, IDIGIT, LOUT - Complex - & CX( * ) - CHARACTER IFMT*( * ) -* ... -* ... SPECIFICATIONS FOR LOCAL VARIABLES - INTEGER I, NDIGIT, K1, K2, LLL - CHARACTER*80 LINE -* ... -* ... FIRST EXECUTABLE STATEMENT -* -* - LLL = MIN( LEN( IFMT ), 80 ) - DO 10 I = 1, LLL - LINE( I: I ) = '-' - 10 CONTINUE -* - DO 20 I = LLL + 1, 80 - LINE( I: I ) = ' ' - 20 CONTINUE -* - WRITE( LOUT, 9999 )IFMT, LINE( 1: LLL ) - 9999 FORMAT( / 1X, A / 1X, A ) -* - IF( N.LE.0 ) - $ RETURN - NDIGIT = IDIGIT - IF( IDIGIT.EQ.0 ) - $ NDIGIT = 4 -* -*======================================================================= -* CODE FOR OUTPUT USING 72 COLUMNS FORMAT -*======================================================================= -* - IF( IDIGIT.LT.0 ) THEN - NDIGIT = -IDIGIT - IF( NDIGIT.LE.4 ) THEN - DO 30 K1 = 1, N, 2 - K2 = MIN0( N, K1+1 ) - IF (K1.NE.N) THEN - WRITE( LOUT, 9998 )K1, K2, ( CX( I ), - $ I = K1, K2 ) - ELSE - WRITE( LOUT, 9997 )K1, K2, ( CX( I ), - $ I = K1, K2 ) - END IF - 30 CONTINUE - ELSE IF( NDIGIT.LE.6 ) THEN - DO 40 K1 = 1, N, 2 - K2 = MIN0( N, K1+1 ) - IF (K1.NE.N) THEN - WRITE( LOUT, 9988 )K1, K2, ( CX( I ), - $ I = K1, K2 ) - ELSE - WRITE( LOUT, 9987 )K1, K2, ( CX( I ), - $ I = K1, K2 ) - END IF - 40 CONTINUE - ELSE IF( NDIGIT.LE.8 ) THEN - DO 50 K1 = 1, N, 2 - K2 = MIN0( N, K1+1 ) - IF (K1.NE.N) THEN - WRITE( LOUT, 9978 )K1, K2, ( CX( I ), - $ I = K1, K2 ) - ELSE - WRITE( LOUT, 9977 )K1, K2, ( CX( I ), - $ I = K1, K2 ) - END IF - 50 CONTINUE - ELSE - DO 60 K1 = 1, N - WRITE( LOUT, 9968 )K1, K1, CX( I ) - 60 CONTINUE - END IF -* -*======================================================================= -* CODE FOR OUTPUT USING 132 COLUMNS FORMAT -*======================================================================= -* - ELSE - IF( NDIGIT.LE.4 ) THEN - DO 70 K1 = 1, N, 4 - K2 = MIN0( N, K1+3 ) - IF ((K1+3).LE.N) THEN - WRITE( LOUT, 9958 )K1, K2, ( CX( I ), - $ I = K1, K2 ) - ELSE IF ((K1+3-N) .EQ. 1) THEN - WRITE( LOUT, 9957 )K1, K2, ( CX( I ), - $ I = K1, K2 ) - ELSE IF ((K1+3-N) .EQ. 2) THEN - WRITE( LOUT, 9956 )K1, K2, ( CX( I ), - $ I = K1, K2 ) - ELSE IF ((K1+3-N) .EQ. 1) THEN - WRITE( LOUT, 9955 )K1, K2, ( CX( I ), - $ I = K1, K2 ) - END IF - 70 CONTINUE - ELSE IF( NDIGIT.LE.6 ) THEN - DO 80 K1 = 1, N, 3 - K2 = MIN0( N, K1+2 ) - IF ((K1+2).LE.N) THEN - WRITE( LOUT, 9948 )K1, K2, ( CX( I ), - $ I = K1, K2 ) - ELSE IF ((K1+2-N) .EQ. 1) THEN - WRITE( LOUT, 9947 )K1, K2, ( CX( I ), - $ I = K1, K2 ) - ELSE IF ((K1+2-N) .EQ. 2) THEN - WRITE( LOUT, 9946 )K1, K2, ( CX( I ), - $ I = K1, K2 ) - END IF - 80 CONTINUE - ELSE IF( NDIGIT.LE.8 ) THEN - DO 90 K1 = 1, N, 3 - K2 = MIN0( N, K1+2 ) - IF ((K1+2).LE.N) THEN - WRITE( LOUT, 9938 )K1, K2, ( CX( I ), - $ I = K1, K2 ) - ELSE IF ((K1+2-N) .EQ. 1) THEN - WRITE( LOUT, 9937 )K1, K2, ( CX( I ), - $ I = K1, K2 ) - ELSE IF ((K1+2-N) .EQ. 2) THEN - WRITE( LOUT, 9936 )K1, K2, ( CX( I ), - $ I = K1, K2 ) - END IF - 90 CONTINUE - ELSE - DO 100 K1 = 1, N, 2 - K2 = MIN0( N, K1+1 ) - IF ((K1+2).LE.N) THEN - WRITE( LOUT, 9928 )K1, K2, ( CX( I ), - $ I = K1, K2 ) - ELSE IF ((K1+2-N) .EQ. 1) THEN - WRITE( LOUT, 9927 )K1, K2, ( CX( I ), - $ I = K1, K2 ) - END IF - 100 CONTINUE - END IF - END IF - WRITE( LOUT, 9994 ) - RETURN -* -*======================================================================= -* FORMAT FOR 72 COLUMNS -*======================================================================= -* -* DISPLAY 4 SIGNIFICANT DIGITS -* - 9998 FORMAT( 1X, I4, ' - ', I4, ':', 1X, - $ 1P,2('(',E10.3,',',E10.3,') ') ) - 9997 FORMAT( 1X, I4, ' - ', I4, ':', 1X, - $ 1P,1('(',E10.3,',',E10.3,') ') ) -* -* DISPLAY 6 SIGNIFICANT DIGITS -* - 9988 FORMAT( 1X, I4, ' - ', I4, ':', 1X, - $ 1P,2('(',E12.5,',',E12.5,') ') ) - 9987 FORMAT( 1X, I4, ' - ', I4, ':', 1X, - $ 1P,1('(',E12.5,',',E12.5,') ') ) -* -* DISPLAY 8 SIGNIFICANT DIGITS -* - 9978 FORMAT( 1X, I4, ' - ', I4, ':', 1X, - $ 1P,2('(',E14.7,',',E14.7,') ') ) - 9977 FORMAT( 1X, I4, ' - ', I4, ':', 1X, - $ 1P,1('(',E14.7,',',E14.7,') ') ) -* -* DISPLAY 13 SIGNIFICANT DIGITS -* - 9968 FORMAT( 1X, I4, ' - ', I4, ':', 1X, - $ 1P,1('(',E20.13,',',E20.13,') ') ) -* -*========================================================================= -* FORMAT FOR 132 COLUMNS -*========================================================================= -* -* DISPLAY 4 SIGNIFICANT DIGITS -* - 9958 FORMAT( 1X, I4, ' - ', I4, ':', 1X, - $ 1P,4('(',E10.3,',',E10.3,') ') ) - 9957 FORMAT( 1X, I4, ' - ', I4, ':', 1X, - $ 1P,3('(',E10.3,',',E10.3,') ') ) - 9956 FORMAT( 1X, I4, ' - ', I4, ':', 1X, - $ 1P,2('(',E10.3,',',E10.3,') ') ) - 9955 FORMAT( 1X, I4, ' - ', I4, ':', 1X, - $ 1P,1('(',E10.3,',',E10.3,') ') ) -* -* DISPLAY 6 SIGNIFICANT DIGITS -* - 9948 FORMAT( 1X, I4, ' - ', I4, ':', 1X, - $ 1P,3('(',E12.5,',',E12.5,') ') ) - 9947 FORMAT( 1X, I4, ' - ', I4, ':', 1X, - $ 1P,2('(',E12.5,',',E12.5,') ') ) - 9946 FORMAT( 1X, I4, ' - ', I4, ':', 1X, - $ 1P,1('(',E12.5,',',E12.5,') ') ) -* -* DISPLAY 8 SIGNIFICANT DIGITS -* - 9938 FORMAT( 1X, I4, ' - ', I4, ':', 1X, - $ 1P,3('(',E14.7,',',E14.7,') ') ) - 9937 FORMAT( 1X, I4, ' - ', I4, ':', 1X, - $ 1P,2('(',E14.7,',',E14.7,') ') ) - 9936 FORMAT( 1X, I4, ' - ', I4, ':', 1X, - $ 1P,1('(',E14.7,',',E14.7,') ') ) -* -* DISPLAY 13 SIGNIFICANT DIGITS -* - 9928 FORMAT( 1X, I4, ' - ', I4, ':', 1X, - $ 1P,2('(',E20.13,',',E20.13,') ') ) - 9927 FORMAT( 1X, I4, ' - ', I4, ':', 1X, - $ 1P,1('(',E20.13,',',E20.13,') ') ) -* -* -* - 9994 FORMAT( 1X, ' ' ) - END
--- a/libcruft/arpack/util/dmout.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,167 +0,0 @@ -*----------------------------------------------------------------------- -* Routine: DMOUT -* -* Purpose: Real matrix output routine. -* -* Usage: CALL DMOUT (LOUT, M, N, A, LDA, IDIGIT, IFMT) -* -* Arguments -* M - Number of rows of A. (Input) -* N - Number of columns of A. (Input) -* A - Real M by N matrix to be printed. (Input) -* LDA - Leading dimension of A exactly as specified in the -* dimension statement of the calling program. (Input) -* IFMT - Format to be used in printing matrix A. (Input) -* IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In) -* If IDIGIT .LT. 0, printing is done with 72 columns. -* If IDIGIT .GT. 0, printing is done with 132 columns. -* -*----------------------------------------------------------------------- -* - SUBROUTINE DMOUT( LOUT, M, N, A, LDA, IDIGIT, IFMT ) -* ... -* ... SPECIFICATIONS FOR ARGUMENTS -* ... -* ... SPECIFICATIONS FOR LOCAL VARIABLES -* .. Scalar Arguments .. - CHARACTER*( * ) IFMT - INTEGER IDIGIT, LDA, LOUT, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* .. Local Scalars .. - CHARACTER*80 LINE - INTEGER I, J, K1, K2, LLL, NDIGIT -* .. -* .. Local Arrays .. - CHARACTER ICOL( 3 ) -* .. -* .. Intrinsic Functions .. - INTRINSIC LEN, MIN, MIN0 -* .. -* .. Data statements .. - DATA ICOL( 1 ), ICOL( 2 ), ICOL( 3 ) / 'C', 'o', - $ 'l' / -* .. -* .. Executable Statements .. -* ... -* ... FIRST EXECUTABLE STATEMENT -* - LLL = MIN( LEN( IFMT ), 80 ) - DO 10 I = 1, LLL - LINE( I: I ) = '-' - 10 CONTINUE -* - DO 20 I = LLL + 1, 80 - LINE( I: I ) = ' ' - 20 CONTINUE -* - WRITE( LOUT, FMT = 9999 )IFMT, LINE( 1: LLL ) - 9999 FORMAT( / 1X, A, / 1X, A ) -* - IF( M.LE.0 .OR. N.LE.0 .OR. LDA.LE.0 ) - $ RETURN - NDIGIT = IDIGIT - IF( IDIGIT.EQ.0 ) - $ NDIGIT = 4 -* -*======================================================================= -* CODE FOR OUTPUT USING 72 COLUMNS FORMAT -*======================================================================= -* - IF( IDIGIT.LT.0 ) THEN - NDIGIT = -IDIGIT - IF( NDIGIT.LE.4 ) THEN - DO 40 K1 = 1, N, 5 - K2 = MIN0( N, K1+4 ) - WRITE( LOUT, FMT = 9998 )( ICOL, I, I = K1, K2 ) - DO 30 I = 1, M - WRITE( LOUT, FMT = 9994 )I, ( A( I, J ), J = K1, K2 ) - 30 CONTINUE - 40 CONTINUE -* - ELSE IF( NDIGIT.LE.6 ) THEN - DO 60 K1 = 1, N, 4 - K2 = MIN0( N, K1+3 ) - WRITE( LOUT, FMT = 9997 )( ICOL, I, I = K1, K2 ) - DO 50 I = 1, M - WRITE( LOUT, FMT = 9993 )I, ( A( I, J ), J = K1, K2 ) - 50 CONTINUE - 60 CONTINUE -* - ELSE IF( NDIGIT.LE.10 ) THEN - DO 80 K1 = 1, N, 3 - K2 = MIN0( N, K1+2 ) - WRITE( LOUT, FMT = 9996 )( ICOL, I, I = K1, K2 ) - DO 70 I = 1, M - WRITE( LOUT, FMT = 9992 )I, ( A( I, J ), J = K1, K2 ) - 70 CONTINUE - 80 CONTINUE -* - ELSE - DO 100 K1 = 1, N, 2 - K2 = MIN0( N, K1+1 ) - WRITE( LOUT, FMT = 9995 )( ICOL, I, I = K1, K2 ) - DO 90 I = 1, M - WRITE( LOUT, FMT = 9991 )I, ( A( I, J ), J = K1, K2 ) - 90 CONTINUE - 100 CONTINUE - END IF -* -*======================================================================= -* CODE FOR OUTPUT USING 132 COLUMNS FORMAT -*======================================================================= -* - ELSE - IF( NDIGIT.LE.4 ) THEN - DO 120 K1 = 1, N, 10 - K2 = MIN0( N, K1+9 ) - WRITE( LOUT, FMT = 9998 )( ICOL, I, I = K1, K2 ) - DO 110 I = 1, M - WRITE( LOUT, FMT = 9994 )I, ( A( I, J ), J = K1, K2 ) - 110 CONTINUE - 120 CONTINUE -* - ELSE IF( NDIGIT.LE.6 ) THEN - DO 140 K1 = 1, N, 8 - K2 = MIN0( N, K1+7 ) - WRITE( LOUT, FMT = 9997 )( ICOL, I, I = K1, K2 ) - DO 130 I = 1, M - WRITE( LOUT, FMT = 9993 )I, ( A( I, J ), J = K1, K2 ) - 130 CONTINUE - 140 CONTINUE -* - ELSE IF( NDIGIT.LE.10 ) THEN - DO 160 K1 = 1, N, 6 - K2 = MIN0( N, K1+5 ) - WRITE( LOUT, FMT = 9996 )( ICOL, I, I = K1, K2 ) - DO 150 I = 1, M - WRITE( LOUT, FMT = 9992 )I, ( A( I, J ), J = K1, K2 ) - 150 CONTINUE - 160 CONTINUE -* - ELSE - DO 180 K1 = 1, N, 5 - K2 = MIN0( N, K1+4 ) - WRITE( LOUT, FMT = 9995 )( ICOL, I, I = K1, K2 ) - DO 170 I = 1, M - WRITE( LOUT, FMT = 9991 )I, ( A( I, J ), J = K1, K2 ) - 170 CONTINUE - 180 CONTINUE - END IF - END IF - WRITE( LOUT, FMT = 9990 ) -* - 9998 FORMAT( 10X, 10( 4X, 3A1, I4, 1X ) ) - 9997 FORMAT( 10X, 8( 5X, 3A1, I4, 2X ) ) - 9996 FORMAT( 10X, 6( 7X, 3A1, I4, 4X ) ) - 9995 FORMAT( 10X, 5( 9X, 3A1, I4, 6X ) ) - 9994 FORMAT( 1X, ' Row', I4, ':', 1X, 1P, 10D12.3 ) - 9993 FORMAT( 1X, ' Row', I4, ':', 1X, 1P, 8D14.5 ) - 9992 FORMAT( 1X, ' Row', I4, ':', 1X, 1P, 6D18.9 ) - 9991 FORMAT( 1X, ' Row', I4, ':', 1X, 1P, 5D22.13 ) - 9990 FORMAT( 1X, ' ' ) -* - RETURN - END
--- a/libcruft/arpack/util/dvout.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,122 +0,0 @@ -*----------------------------------------------------------------------- -* Routine: DVOUT -* -* Purpose: Real vector output routine. -* -* Usage: CALL DVOUT (LOUT, N, SX, IDIGIT, IFMT) -* -* Arguments -* N - Length of array SX. (Input) -* SX - Real array to be printed. (Input) -* IFMT - Format to be used in printing array SX. (Input) -* IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In) -* If IDIGIT .LT. 0, printing is done with 72 columns. -* If IDIGIT .GT. 0, printing is done with 132 columns. -* -*----------------------------------------------------------------------- -* - SUBROUTINE DVOUT( LOUT, N, SX, IDIGIT, IFMT ) -* ... -* ... SPECIFICATIONS FOR ARGUMENTS -* ... -* ... SPECIFICATIONS FOR LOCAL VARIABLES -* .. Scalar Arguments .. - CHARACTER*( * ) IFMT - INTEGER IDIGIT, LOUT, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION SX( * ) -* .. -* .. Local Scalars .. - CHARACTER*80 LINE - INTEGER I, K1, K2, LLL, NDIGIT -* .. -* .. Intrinsic Functions .. - INTRINSIC LEN, MIN, MIN0 -* .. -* .. Executable Statements .. -* ... -* ... FIRST EXECUTABLE STATEMENT -* -* - LLL = MIN( LEN( IFMT ), 80 ) - DO 10 I = 1, LLL - LINE( I: I ) = '-' - 10 CONTINUE -* - DO 20 I = LLL + 1, 80 - LINE( I: I ) = ' ' - 20 CONTINUE -* - WRITE( LOUT, FMT = 9999 )IFMT, LINE( 1: LLL ) - 9999 FORMAT( / 1X, A, / 1X, A ) -* - IF( N.LE.0 ) - $ RETURN - NDIGIT = IDIGIT - IF( IDIGIT.EQ.0 ) - $ NDIGIT = 4 -* -*======================================================================= -* CODE FOR OUTPUT USING 72 COLUMNS FORMAT -*======================================================================= -* - IF( IDIGIT.LT.0 ) THEN - NDIGIT = -IDIGIT - IF( NDIGIT.LE.4 ) THEN - DO 30 K1 = 1, N, 5 - K2 = MIN0( N, K1+4 ) - WRITE( LOUT, FMT = 9998 )K1, K2, ( SX( I ), I = K1, K2 ) - 30 CONTINUE - ELSE IF( NDIGIT.LE.6 ) THEN - DO 40 K1 = 1, N, 4 - K2 = MIN0( N, K1+3 ) - WRITE( LOUT, FMT = 9997 )K1, K2, ( SX( I ), I = K1, K2 ) - 40 CONTINUE - ELSE IF( NDIGIT.LE.10 ) THEN - DO 50 K1 = 1, N, 3 - K2 = MIN0( N, K1+2 ) - WRITE( LOUT, FMT = 9996 )K1, K2, ( SX( I ), I = K1, K2 ) - 50 CONTINUE - ELSE - DO 60 K1 = 1, N, 2 - K2 = MIN0( N, K1+1 ) - WRITE( LOUT, FMT = 9995 )K1, K2, ( SX( I ), I = K1, K2 ) - 60 CONTINUE - END IF -* -*======================================================================= -* CODE FOR OUTPUT USING 132 COLUMNS FORMAT -*======================================================================= -* - ELSE - IF( NDIGIT.LE.4 ) THEN - DO 70 K1 = 1, N, 10 - K2 = MIN0( N, K1+9 ) - WRITE( LOUT, FMT = 9998 )K1, K2, ( SX( I ), I = K1, K2 ) - 70 CONTINUE - ELSE IF( NDIGIT.LE.6 ) THEN - DO 80 K1 = 1, N, 8 - K2 = MIN0( N, K1+7 ) - WRITE( LOUT, FMT = 9997 )K1, K2, ( SX( I ), I = K1, K2 ) - 80 CONTINUE - ELSE IF( NDIGIT.LE.10 ) THEN - DO 90 K1 = 1, N, 6 - K2 = MIN0( N, K1+5 ) - WRITE( LOUT, FMT = 9996 )K1, K2, ( SX( I ), I = K1, K2 ) - 90 CONTINUE - ELSE - DO 100 K1 = 1, N, 5 - K2 = MIN0( N, K1+4 ) - WRITE( LOUT, FMT = 9995 )K1, K2, ( SX( I ), I = K1, K2 ) - 100 CONTINUE - END IF - END IF - WRITE( LOUT, FMT = 9994 ) - RETURN - 9998 FORMAT( 1X, I4, ' - ', I4, ':', 1P, 10D12.3 ) - 9997 FORMAT( 1X, I4, ' - ', I4, ':', 1X, 1P, 8D14.5 ) - 9996 FORMAT( 1X, I4, ' - ', I4, ':', 1X, 1P, 6D18.9 ) - 9995 FORMAT( 1X, I4, ' - ', I4, ':', 1X, 1P, 5D24.13 ) - 9994 FORMAT( 1X, ' ' ) - END
--- a/libcruft/arpack/util/icnteq.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,18 +0,0 @@ -c -c----------------------------------------------------------------------- -c -c Count the number of elements equal to a specified integer value. -c - integer function icnteq (n, array, value) -c - integer n, value - integer array(*) -c - k = 0 - do 10 i = 1, n - if (array(i) .eq. value) k = k + 1 - 10 continue - icnteq = k -c - return - end
--- a/libcruft/arpack/util/icopy.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,77 +0,0 @@ -*-------------------------------------------------------------------- -*\Documentation -* -*\Name: ICOPY -* -*\Description: -* ICOPY copies an integer vector lx to an integer vector ly. -* -*\Usage: -* call icopy ( n, lx, inc, ly, incy ) -* -*\Arguments: -* n integer (input) -* On entry, n is the number of elements of lx to be -c copied to ly. -* -* lx integer array (input) -* On entry, lx is the integer vector to be copied. -* -* incx integer (input) -* On entry, incx is the increment between elements of lx. -* -* ly integer array (input) -* On exit, ly is the integer vector that contains the -* copy of lx. -* -* incy integer (input) -* On entry, incy is the increment between elements of ly. -* -*\Enddoc -* -*-------------------------------------------------------------------- -* - subroutine icopy( n, lx, incx, ly, incy ) -* -* ---------------------------- -* Specifications for arguments -* ---------------------------- - integer incx, incy, n - integer lx( 1 ), ly( 1 ) -* -* ---------------------------------- -* Specifications for local variables -* ---------------------------------- - integer i, ix, iy -* -* -------------------------- -* First executable statement -* -------------------------- - if( n.le.0 ) - $ return - if( incx.eq.1 .and. incy.eq.1 ) - $ go to 20 -c -c.....code for unequal increments or equal increments -c 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 - ly( iy ) = lx( ix ) - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c.....code for both increments equal to 1 -c - 20 continue - do 30 i = 1, n - ly( i ) = lx( i ) - 30 continue - return - end
--- a/libcruft/arpack/util/iset.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,16 +0,0 @@ -c -c----------------------------------------------------------------------- -c -c Only work with increment equal to 1 right now. -c - subroutine iset (n, value, array, inc) -c - integer n, value, inc - integer array(*) -c - do 10 i = 1, n - array(i) = value - 10 continue -c - return - end
--- a/libcruft/arpack/util/iswap.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,55 +0,0 @@ - subroutine iswap (n,sx,incx,sy,incy) -c -c interchanges two vectors. -c uses unrolled loops for increments equal to 1. -c jack dongarra, linpack, 3/11/78. -c - integer sx(1),sy(1),stemp - integer i,incx,incy,ix,iy,m,mp1,n -c - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments not equal -c to 1 -c - 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 -c -c code for both increments equal to 1 -c -c -c clean-up loop -c - 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
--- a/libcruft/arpack/util/ivout.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,120 +0,0 @@ -C----------------------------------------------------------------------- -C Routine: IVOUT -C -C Purpose: Integer vector output routine. -C -C Usage: CALL IVOUT (LOUT, N, IX, IDIGIT, IFMT) -C -C Arguments -C N - Length of array IX. (Input) -C IX - Integer array to be printed. (Input) -C IFMT - Format to be used in printing array IX. (Input) -C IDIGIT - Print up to ABS(IDIGIT) decimal digits / number. (Input) -C If IDIGIT .LT. 0, printing is done with 72 columns. -C If IDIGIT .GT. 0, printing is done with 132 columns. -C -C----------------------------------------------------------------------- -C - SUBROUTINE IVOUT (LOUT, N, IX, IDIGIT, IFMT) -C ... -C ... SPECIFICATIONS FOR ARGUMENTS - INTEGER IX(*), N, IDIGIT, LOUT - CHARACTER IFMT*(*) -C ... -C ... SPECIFICATIONS FOR LOCAL VARIABLES - INTEGER I, NDIGIT, K1, K2, LLL - CHARACTER*80 LINE -* ... -* ... SPECIFICATIONS INTRINSICS - INTRINSIC MIN -* -C - LLL = MIN ( LEN ( IFMT ), 80 ) - DO 1 I = 1, LLL - LINE(I:I) = '-' - 1 CONTINUE -C - DO 2 I = LLL+1, 80 - LINE(I:I) = ' ' - 2 CONTINUE -C - WRITE ( LOUT, 2000 ) IFMT, LINE(1:LLL) - 2000 FORMAT ( /1X, A /1X, A ) -C - IF (N .LE. 0) RETURN - NDIGIT = IDIGIT - IF (IDIGIT .EQ. 0) NDIGIT = 4 -C -C======================================================================= -C CODE FOR OUTPUT USING 72 COLUMNS FORMAT -C======================================================================= -C - IF (IDIGIT .LT. 0) THEN -C - NDIGIT = -IDIGIT - IF (NDIGIT .LE. 4) THEN - DO 10 K1 = 1, N, 10 - K2 = MIN0(N,K1+9) - WRITE(LOUT,1000) K1,K2,(IX(I),I=K1,K2) - 10 CONTINUE -C - ELSE IF (NDIGIT .LE. 6) THEN - DO 30 K1 = 1, N, 7 - K2 = MIN0(N,K1+6) - WRITE(LOUT,1001) K1,K2,(IX(I),I=K1,K2) - 30 CONTINUE -C - ELSE IF (NDIGIT .LE. 10) THEN - DO 50 K1 = 1, N, 5 - K2 = MIN0(N,K1+4) - WRITE(LOUT,1002) K1,K2,(IX(I),I=K1,K2) - 50 CONTINUE -C - ELSE - DO 70 K1 = 1, N, 3 - K2 = MIN0(N,K1+2) - WRITE(LOUT,1003) K1,K2,(IX(I),I=K1,K2) - 70 CONTINUE - END IF -C -C======================================================================= -C CODE FOR OUTPUT USING 132 COLUMNS FORMAT -C======================================================================= -C - ELSE -C - IF (NDIGIT .LE. 4) THEN - DO 90 K1 = 1, N, 20 - K2 = MIN0(N,K1+19) - WRITE(LOUT,1000) K1,K2,(IX(I),I=K1,K2) - 90 CONTINUE -C - ELSE IF (NDIGIT .LE. 6) THEN - DO 110 K1 = 1, N, 15 - K2 = MIN0(N,K1+14) - WRITE(LOUT,1001) K1,K2,(IX(I),I=K1,K2) - 110 CONTINUE -C - ELSE IF (NDIGIT .LE. 10) THEN - DO 130 K1 = 1, N, 10 - K2 = MIN0(N,K1+9) - WRITE(LOUT,1002) K1,K2,(IX(I),I=K1,K2) - 130 CONTINUE -C - ELSE - DO 150 K1 = 1, N, 7 - K2 = MIN0(N,K1+6) - WRITE(LOUT,1003) K1,K2,(IX(I),I=K1,K2) - 150 CONTINUE - END IF - END IF - WRITE (LOUT,1004) -C - 1000 FORMAT(1X,I4,' - ',I4,':',20(1X,I5)) - 1001 FORMAT(1X,I4,' - ',I4,':',15(1X,I7)) - 1002 FORMAT(1X,I4,' - ',I4,':',10(1X,I11)) - 1003 FORMAT(1X,I4,' - ',I4,':',7(1X,I15)) - 1004 FORMAT(1X,' ') -C - RETURN - END
--- a/libcruft/arpack/util/second.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,36 +0,0 @@ - SUBROUTINE ARSCND( T ) -* - REAL T -* -* -- LAPACK auxiliary routine (preliminary version) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* July 26, 1991 -* -* Purpose -* ======= -* -* SECOND returns the user time for a process in arscnds. -* This version gets the time from the system function ETIME. -* -* .. Local Scalars .. - REAL T1 -* .. -* .. Local Arrays .. - REAL TARRAY( 2 ) -* .. -* .. External Functions .. - REAL ETIME - INTRINSIC ETIME -* .. -* .. Executable Statements .. -* - - T1 = ETIME( TARRAY ) - T = TARRAY( 1 ) - - RETURN -* -* End of ARSCND -* - END
--- a/libcruft/arpack/util/smout.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,157 +0,0 @@ -*----------------------------------------------------------------------- -* Routine: SMOUT -* -* Purpose: Real matrix output routine. -* -* Usage: CALL SMOUT (LOUT, M, N, A, LDA, IDIGIT, IFMT) -* -* Arguments -* M - Number of rows of A. (Input) -* N - Number of columns of A. (Input) -* A - Real M by N matrix to be printed. (Input) -* LDA - Leading dimension of A exactly as specified in the -* dimension statement of the calling program. (Input) -* IFMT - Format to be used in printing matrix A. (Input) -* IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In) -* If IDIGIT .LT. 0, printing is done with 72 columns. -* If IDIGIT .GT. 0, printing is done with 132 columns. -* -*----------------------------------------------------------------------- -* - SUBROUTINE SMOUT( LOUT, M, N, A, LDA, IDIGIT, IFMT ) -* ... -* ... SPECIFICATIONS FOR ARGUMENTS - INTEGER M, N, IDIGIT, LDA, LOUT - REAL A( LDA, * ) - CHARACTER IFMT*( * ) -* ... -* ... SPECIFICATIONS FOR LOCAL VARIABLES - INTEGER I, J, NDIGIT, K1, K2, LLL - CHARACTER*1 ICOL( 3 ) - CHARACTER*80 LINE -* ... -* ... SPECIFICATIONS INTRINSICS - INTRINSIC MIN -* - DATA ICOL( 1 ), ICOL( 2 ), ICOL( 3 ) / 'C', 'o', - $ 'l' / -* ... -* ... FIRST EXECUTABLE STATEMENT -* - LLL = MIN( LEN( IFMT ), 80 ) - DO 10 I = 1, LLL - LINE( I: I ) = '-' - 10 CONTINUE -* - DO 20 I = LLL + 1, 80 - LINE( I: I ) = ' ' - 20 CONTINUE -* - WRITE( LOUT, 9999 )IFMT, LINE( 1: LLL ) - 9999 FORMAT( / 1X, A / 1X, A ) -* - IF( M.LE.0 .OR. N.LE.0 .OR. LDA.LE.0 ) - $ RETURN - NDIGIT = IDIGIT - IF( IDIGIT.EQ.0 ) - $ NDIGIT = 4 -* -*======================================================================= -* CODE FOR OUTPUT USING 72 COLUMNS FORMAT -*======================================================================= -* - IF( IDIGIT.LT.0 ) THEN - NDIGIT = -IDIGIT - IF( NDIGIT.LE.4 ) THEN - DO 40 K1 = 1, N, 5 - K2 = MIN0( N, K1+4 ) - WRITE( LOUT, 9998 )( ICOL, I, I = K1, K2 ) - DO 30 I = 1, M - WRITE( LOUT, 9994 )I, ( A( I, J ), J = K1, K2 ) - 30 CONTINUE - 40 CONTINUE -* - ELSE IF( NDIGIT.LE.6 ) THEN - DO 60 K1 = 1, N, 4 - K2 = MIN0( N, K1+3 ) - WRITE( LOUT, 9997 )( ICOL, I, I = K1, K2 ) - DO 50 I = 1, M - WRITE( LOUT, 9993 )I, ( A( I, J ), J = K1, K2 ) - 50 CONTINUE - 60 CONTINUE -* - ELSE IF( NDIGIT.LE.10 ) THEN - DO 80 K1 = 1, N, 3 - K2 = MIN0( N, K1+2 ) - WRITE( LOUT, 9996 )( ICOL, I, I = K1, K2 ) - DO 70 I = 1, M - WRITE( LOUT, 9992 )I, ( A( I, J ), J = K1, K2 ) - 70 CONTINUE - 80 CONTINUE -* - ELSE - DO 100 K1 = 1, N, 2 - K2 = MIN0( N, K1+1 ) - WRITE( LOUT, 9995 )( ICOL, I, I = K1, K2 ) - DO 90 I = 1, M - WRITE( LOUT, 9991 )I, ( A( I, J ), J = K1, K2 ) - 90 CONTINUE - 100 CONTINUE - END IF -* -*======================================================================= -* CODE FOR OUTPUT USING 132 COLUMNS FORMAT -*======================================================================= -* - ELSE - IF( NDIGIT.LE.4 ) THEN - DO 120 K1 = 1, N, 10 - K2 = MIN0( N, K1+9 ) - WRITE( LOUT, 9998 )( ICOL, I, I = K1, K2 ) - DO 110 I = 1, M - WRITE( LOUT, 9994 )I, ( A( I, J ), J = K1, K2 ) - 110 CONTINUE - 120 CONTINUE -* - ELSE IF( NDIGIT.LE.6 ) THEN - DO 140 K1 = 1, N, 8 - K2 = MIN0( N, K1+7 ) - WRITE( LOUT, 9997 )( ICOL, I, I = K1, K2 ) - DO 130 I = 1, M - WRITE( LOUT, 9993 )I, ( A( I, J ), J = K1, K2 ) - 130 CONTINUE - 140 CONTINUE -* - ELSE IF( NDIGIT.LE.10 ) THEN - DO 160 K1 = 1, N, 6 - K2 = MIN0( N, K1+5 ) - WRITE( LOUT, 9996 )( ICOL, I, I = K1, K2 ) - DO 150 I = 1, M - WRITE( LOUT, 9992 )I, ( A( I, J ), J = K1, K2 ) - 150 CONTINUE - 160 CONTINUE -* - ELSE - DO 180 K1 = 1, N, 5 - K2 = MIN0( N, K1+4 ) - WRITE( LOUT, 9995 )( ICOL, I, I = K1, K2 ) - DO 170 I = 1, M - WRITE( LOUT, 9991 )I, ( A( I, J ), J = K1, K2 ) - 170 CONTINUE - 180 CONTINUE - END IF - END IF - WRITE( LOUT, 9990 ) -* - 9998 FORMAT( 10X, 10( 4X, 3A1, I4, 1X ) ) - 9997 FORMAT( 10X, 8( 5X, 3A1, I4, 2X ) ) - 9996 FORMAT( 10X, 6( 7X, 3A1, I4, 4X ) ) - 9995 FORMAT( 10X, 5( 9X, 3A1, I4, 6X ) ) - 9994 FORMAT( 1X, ' Row', I4, ':', 1X, 1P10E12.3 ) - 9993 FORMAT( 1X, ' Row', I4, ':', 1X, 1P8E14.5 ) - 9992 FORMAT( 1X, ' Row', I4, ':', 1X, 1P6E18.9 ) - 9991 FORMAT( 1X, ' Row', I4, ':', 1X, 1P5E22.13 ) - 9990 FORMAT( 1X, ' ' ) -* - RETURN - END
--- a/libcruft/arpack/util/svout.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,112 +0,0 @@ -*----------------------------------------------------------------------- -* Routine: SVOUT -* -* Purpose: Real vector output routine. -* -* Usage: CALL SVOUT (LOUT, N, SX, IDIGIT, IFMT) -* -* Arguments -* N - Length of array SX. (Input) -* SX - Real array to be printed. (Input) -* IFMT - Format to be used in printing array SX. (Input) -* IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In) -* If IDIGIT .LT. 0, printing is done with 72 columns. -* If IDIGIT .GT. 0, printing is done with 132 columns. -* -*----------------------------------------------------------------------- -* - SUBROUTINE SVOUT( LOUT, N, SX, IDIGIT, IFMT ) -* ... -* ... SPECIFICATIONS FOR ARGUMENTS - INTEGER N, IDIGIT, LOUT - REAL SX( * ) - CHARACTER IFMT*( * ) -* ... -* ... SPECIFICATIONS FOR LOCAL VARIABLES - INTEGER I, NDIGIT, K1, K2, LLL - CHARACTER*80 LINE -* ... -* ... FIRST EXECUTABLE STATEMENT -* -* - LLL = MIN( LEN( IFMT ), 80 ) - DO 10 I = 1, LLL - LINE( I: I ) = '-' - 10 CONTINUE -* - DO 20 I = LLL + 1, 80 - LINE( I: I ) = ' ' - 20 CONTINUE -* - WRITE( LOUT, 9999 )IFMT, LINE( 1: LLL ) - 9999 FORMAT( / 1X, A / 1X, A ) -* - IF( N.LE.0 ) - $ RETURN - NDIGIT = IDIGIT - IF( IDIGIT.EQ.0 ) - $ NDIGIT = 4 -* -*======================================================================= -* CODE FOR OUTPUT USING 72 COLUMNS FORMAT -*======================================================================= -* - IF( IDIGIT.LT.0 ) THEN - NDIGIT = -IDIGIT - IF( NDIGIT.LE.4 ) THEN - DO 30 K1 = 1, N, 5 - K2 = MIN0( N, K1+4 ) - WRITE( LOUT, 9998 )K1, K2, ( SX( I ), I = K1, K2 ) - 30 CONTINUE - ELSE IF( NDIGIT.LE.6 ) THEN - DO 40 K1 = 1, N, 4 - K2 = MIN0( N, K1+3 ) - WRITE( LOUT, 9997 )K1, K2, ( SX( I ), I = K1, K2 ) - 40 CONTINUE - ELSE IF( NDIGIT.LE.10 ) THEN - DO 50 K1 = 1, N, 3 - K2 = MIN0( N, K1+2 ) - WRITE( LOUT, 9996 )K1, K2, ( SX( I ), I = K1, K2 ) - 50 CONTINUE - ELSE - DO 60 K1 = 1, N, 2 - K2 = MIN0( N, K1+1 ) - WRITE( LOUT, 9995 )K1, K2, ( SX( I ), I = K1, K2 ) - 60 CONTINUE - END IF -* -*======================================================================= -* CODE FOR OUTPUT USING 132 COLUMNS FORMAT -*======================================================================= -* - ELSE - IF( NDIGIT.LE.4 ) THEN - DO 70 K1 = 1, N, 10 - K2 = MIN0( N, K1+9 ) - WRITE( LOUT, 9998 )K1, K2, ( SX( I ), I = K1, K2 ) - 70 CONTINUE - ELSE IF( NDIGIT.LE.6 ) THEN - DO 80 K1 = 1, N, 8 - K2 = MIN0( N, K1+7 ) - WRITE( LOUT, 9997 )K1, K2, ( SX( I ), I = K1, K2 ) - 80 CONTINUE - ELSE IF( NDIGIT.LE.10 ) THEN - DO 90 K1 = 1, N, 6 - K2 = MIN0( N, K1+5 ) - WRITE( LOUT, 9996 )K1, K2, ( SX( I ), I = K1, K2 ) - 90 CONTINUE - ELSE - DO 100 K1 = 1, N, 5 - K2 = MIN0( N, K1+4 ) - WRITE( LOUT, 9995 )K1, K2, ( SX( I ), I = K1, K2 ) - 100 CONTINUE - END IF - END IF - WRITE( LOUT, 9994 ) - RETURN - 9998 FORMAT( 1X, I4, ' - ', I4, ':', 1P10E12.3 ) - 9997 FORMAT( 1X, I4, ' - ', I4, ':', 1X, 1P8E14.5 ) - 9996 FORMAT( 1X, I4, ' - ', I4, ':', 1X, 1P6E18.9 ) - 9995 FORMAT( 1X, I4, ' - ', I4, ':', 1X, 1P5E24.13 ) - 9994 FORMAT( 1X, ' ' ) - END
--- a/libcruft/arpack/util/zmout.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,250 +0,0 @@ -* -* Routine: ZMOUT -* -* Purpose: Complex*16 matrix output routine. -* -* Usage: CALL ZMOUT (LOUT, M, N, A, LDA, IDIGIT, IFMT) -* -* Arguments -* M - Number of rows of A. (Input) -* N - Number of columns of A. (Input) -* A - Complex*16 M by N matrix to be printed. (Input) -* LDA - Leading dimension of A exactly as specified in the -* dimension statement of the calling program. (Input) -* IFMT - Format to be used in printing matrix A. (Input) -* IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In) -* If IDIGIT .LT. 0, printing is done with 72 columns. -* If IDIGIT .GT. 0, printing is done with 132 columns. -* -*\SCCS Information: @(#) -* FILE: zmout.f SID: 2.1 DATE OF SID: 11/16/95 RELEASE: 2 -* -*----------------------------------------------------------------------- -* - SUBROUTINE ZMOUT( LOUT, M, N, A, LDA, IDIGIT, IFMT ) -* ... -* ... SPECIFICATIONS FOR ARGUMENTS - INTEGER M, N, IDIGIT, LDA, LOUT - Complex*16 - & A( LDA, * ) - CHARACTER IFMT*( * ) -* ... -* ... SPECIFICATIONS FOR LOCAL VARIABLES - INTEGER I, J, NDIGIT, K1, K2, LLL - CHARACTER*1 ICOL( 3 ) - CHARACTER*80 LINE -* ... -* ... SPECIFICATIONS INTRINSICS - INTRINSIC MIN -* - DATA ICOL( 1 ), ICOL( 2 ), ICOL( 3 ) / 'C', 'o', - $ 'l' / -* ... -* ... FIRST EXECUTABLE STATEMENT -* - LLL = MIN( LEN( IFMT ), 80 ) - DO 10 I = 1, LLL - LINE( I: I ) = '-' - 10 CONTINUE -* - DO 20 I = LLL + 1, 80 - LINE( I: I ) = ' ' - 20 CONTINUE -* - WRITE( LOUT, 9999 )IFMT, LINE( 1: LLL ) - 9999 FORMAT( / 1X, A / 1X, A ) -* - IF( M.LE.0 .OR. N.LE.0 .OR. LDA.LE.0 ) - $ RETURN - NDIGIT = IDIGIT - IF( IDIGIT.EQ.0 ) - $ NDIGIT = 4 -* -*======================================================================= -* CODE FOR OUTPUT USING 72 COLUMNS FORMAT -*======================================================================= -* - IF( IDIGIT.LT.0 ) THEN - NDIGIT = -IDIGIT - IF( NDIGIT.LE.4 ) THEN - DO 40 K1 = 1, N, 2 - K2 = MIN0( N, K1+1 ) - WRITE( LOUT, 9998 )( ICOL, I, I = K1, K2 ) - DO 30 I = 1, M - IF (K1.NE.N) THEN - WRITE( LOUT, 9994 )I, ( A( I, J ), J = K1, K2 ) - ELSE - WRITE( LOUT, 9984 )I, ( A( I, J ), J = K1, K2 ) - END IF - 30 CONTINUE - 40 CONTINUE -* - ELSE IF( NDIGIT.LE.6 ) THEN - DO 60 K1 = 1, N, 2 - K2 = MIN0( N, K1+1 ) - WRITE( LOUT, 9997 )( ICOL, I, I = K1, K2 ) - DO 50 I = 1, M - IF (K1.NE.N) THEN - WRITE( LOUT, 9993 )I, ( A( I, J ), J = K1, K2 ) - ELSE - WRITE( LOUT, 9983 )I, ( A( I, J ), J = K1, K2 ) - END IF - 50 CONTINUE - 60 CONTINUE -* - ELSE IF( NDIGIT.LE.8 ) THEN - DO 80 K1 = 1, N, 2 - K2 = MIN0( N, K1+1 ) - WRITE( LOUT, 9996 )( ICOL, I, I = K1, K2 ) - DO 70 I = 1, M - IF (K1.NE.N) THEN - WRITE( LOUT, 9992 )I, ( A( I, J ), J = K1, K2 ) - ELSE - WRITE( LOUT, 9982 )I, ( A( I, J ), J = K1, K2 ) - END IF - 70 CONTINUE - 80 CONTINUE -* - ELSE - DO 100 K1 = 1, N - WRITE( LOUT, 9995 ) ICOL, K1 - DO 90 I = 1, M - WRITE( LOUT, 9991 )I, A( I, K1 ) - 90 CONTINUE - 100 CONTINUE - END IF -* -*======================================================================= -* CODE FOR OUTPUT USING 132 COLUMNS FORMAT -*======================================================================= -* - ELSE - IF( NDIGIT.LE.4 ) THEN - DO 120 K1 = 1, N, 4 - K2 = MIN0( N, K1+3 ) - WRITE( LOUT, 9998 )( ICOL, I, I = K1, K2 ) - DO 110 I = 1, M - IF ((K1+3).LE.N) THEN - WRITE( LOUT, 9974 )I, ( A( I, J ), J = K1, K2 ) - ELSE IF ((K1+3-N).EQ.1) THEN - WRITE( LOUT, 9964 )I, ( A( I, J ), J = k1, K2 ) - ELSE IF ((K1+3-N).EQ.2) THEN - WRITE( LOUT, 9954 )I, ( A( I, J ), J = K1, K2 ) - ELSE IF ((K1+3-N).EQ.3) THEN - WRITE( LOUT, 9944 )I, ( A( I, J ), J = K1, K2 ) - END IF - 110 CONTINUE - 120 CONTINUE -* - ELSE IF( NDIGIT.LE.6 ) THEN - DO 140 K1 = 1, N, 3 - K2 = MIN0( N, K1+ 2) - WRITE( LOUT, 9997 )( ICOL, I, I = K1, K2 ) - DO 130 I = 1, M - IF ((K1+2).LE.N) THEN - WRITE( LOUT, 9973 )I, ( A( I, J ), J = K1, K2 ) - ELSE IF ((K1+2-N).EQ.1) THEN - WRITE( LOUT, 9963 )I, ( A( I, J ), J = K1, K2 ) - ELSE IF ((K1+2-N).EQ.2) THEN - WRITE( LOUT, 9953 )I, ( A( I, J ), J = K1, K2 ) - END IF - 130 CONTINUE - 140 CONTINUE -* - ELSE IF( NDIGIT.LE.8 ) THEN - DO 160 K1 = 1, N, 3 - K2 = MIN0( N, K1+2 ) - WRITE( LOUT, 9996 )( ICOL, I, I = K1, K2 ) - DO 150 I = 1, M - IF ((K1+2).LE.N) THEN - WRITE( LOUT, 9972 )I, ( A( I, J ), J = K1, K2 ) - ELSE IF ((K1+2-N).EQ.1) THEN - WRITE( LOUT, 9962 )I, ( A( I, J ), J = K1, K2 ) - ELSE IF ((K1+2-N).EQ.2) THEN - WRITE( LOUT, 9952 )I, ( A( I, J ), J = K1, K2 ) - END IF - 150 CONTINUE - 160 CONTINUE -* - ELSE - DO 180 K1 = 1, N, 2 - K2 = MIN0( N, K1+1 ) - WRITE( LOUT, 9995 )( ICOL, I, I = K1, K2 ) - DO 170 I = 1, M - IF ((K1+1).LE.N) THEN - WRITE( LOUT, 9971 )I, ( A( I, J ), J = K1, K2 ) - ELSE - WRITE( LOUT, 9961 )I, ( A( I, J ), J = K1, K2 ) - END IF - 170 CONTINUE - 180 CONTINUE - END IF - END IF - WRITE( LOUT, 9990 ) -* - 9998 FORMAT( 11X, 4( 9X, 3A1, I4, 9X ) ) - 9997 FORMAT( 10X, 4( 11X, 3A1, I4, 11X ) ) - 9996 FORMAT( 10X, 3( 13X, 3A1, I4, 13X ) ) - 9995 FORMAT( 12X, 2( 18x, 3A1, I4, 18X ) ) -* -*======================================================== -* FORMAT FOR 72 COLUMN -*======================================================== -* -* DISPLAY 4 SIGNIFICANT DIGITS -* - 9994 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',D10.3,',',D10.3,') ') ) - 9984 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',D10.3,',',D10.3,') ') ) -* -* DISPLAY 6 SIGNIFICANT DIGITS -* - 9993 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',D12.5,',',D12.5,') ') ) - 9983 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',D12.5,',',D12.5,') ') ) -* -* DISPLAY 8 SIGNIFICANT DIGITS -* - 9992 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',D14.7,',',D14.7,') ') ) - 9982 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',D14.7,',',D14.7,') ') ) -* -* DISPLAY 13 SIGNIFICANT DIGITS -* - 9991 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',D20.13,',',D20.13,')') ) - 9990 FORMAT( 1X, ' ' ) -* -* -*======================================================== -* FORMAT FOR 132 COLUMN -*======================================================== -* -* DISPLAY 4 SIGNIFICANT DIGIT -* - 9974 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,4('(',D10.3,',',D10.3,') ') ) - 9964 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,3('(',D10.3,',',D10.3,') ') ) - 9954 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',D10.3,',',D10.3,') ') ) - 9944 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',D10.3,',',D10.3,') ') ) -* -* DISPLAY 6 SIGNIFICANT DIGIT -* - 9973 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,3('(',D12.5,',',D12.5,') ') ) - 9963 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',D12.5,',',D12.5,') ') ) - 9953 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',D12.5,',',D12.5,') ') ) -* -* DISPLAY 8 SIGNIFICANT DIGIT -* - 9972 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,3('(',D14.7,',',D14.7,') ') ) - 9962 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',D14.7,',',D14.7,') ') ) - 9952 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',D14.7,',',D14.7,') ') ) -* -* DISPLAY 13 SIGNIFICANT DIGIT -* - 9971 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',D20.13,',',D20.13, - & ') ')) - 9961 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',D20.13,',',D20.13, - & ') ')) - -* -* -* -* - RETURN - END
--- a/libcruft/arpack/util/zvout.f Mon Jan 02 15:19:45 2012 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,240 +0,0 @@ -c----------------------------------------------------------------------- -c -c\SCCS Information: @(#) -c FILE: zvout.f SID: 2.1 DATE OF SID: 11/16/95 RELEASE: 2 -c -*----------------------------------------------------------------------- -* Routine: ZVOUT -* -* Purpose: Complex*16 vector output routine. -* -* Usage: CALL ZVOUT (LOUT, N, CX, IDIGIT, IFMT) -* -* Arguments -* N - Length of array CX. (Input) -* CX - Complex*16 array to be printed. (Input) -* IFMT - Format to be used in printing array CX. (Input) -* IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In) -* If IDIGIT .LT. 0, printing is done with 72 columns. -* If IDIGIT .GT. 0, printing is done with 132 columns. -* -*----------------------------------------------------------------------- -* - SUBROUTINE ZVOUT( LOUT, N, CX, IDIGIT, IFMT ) -* ... -* ... SPECIFICATIONS FOR ARGUMENTS - INTEGER N, IDIGIT, LOUT - Complex*16 - & CX( * ) - CHARACTER IFMT*( * ) -* ... -* ... SPECIFICATIONS FOR LOCAL VARIABLES - INTEGER I, NDIGIT, K1, K2, LLL - CHARACTER*80 LINE -* ... -* ... FIRST EXECUTABLE STATEMENT -* -* - LLL = MIN( LEN( IFMT ), 80 ) - DO 10 I = 1, LLL - LINE( I: I ) = '-' - 10 CONTINUE -* - DO 20 I = LLL + 1, 80 - LINE( I: I ) = ' ' - 20 CONTINUE -* - WRITE( LOUT, 9999 )IFMT, LINE( 1: LLL ) - 9999 FORMAT( / 1X, A / 1X, A ) -* - IF( N.LE.0 ) - $ RETURN - NDIGIT = IDIGIT - IF( IDIGIT.EQ.0 ) - $ NDIGIT = 4 -* -*======================================================================= -* CODE FOR OUTPUT USING 72 COLUMNS FORMAT -*======================================================================= -* - IF( IDIGIT.LT.0 ) THEN - NDIGIT = -IDIGIT - IF( NDIGIT.LE.4 ) THEN - DO 30 K1 = 1, N, 2 - K2 = MIN0( N, K1+1 ) - IF (K1.NE.N) THEN - WRITE( LOUT, 9998 )K1, K2, ( CX( I ), - $ I = K1, K2 ) - ELSE - WRITE( LOUT, 9997 )K1, K2, ( CX( I ), - $ I = K1, K2 ) - END IF - 30 CONTINUE - ELSE IF( NDIGIT.LE.6 ) THEN - DO 40 K1 = 1, N, 2 - K2 = MIN0( N, K1+1 ) - IF (K1.NE.N) THEN - WRITE( LOUT, 9988 )K1, K2, ( CX( I ), - $ I = K1, K2 ) - ELSE - WRITE( LOUT, 9987 )K1, K2, ( CX( I ), - $ I = K1, K2 ) - END IF - 40 CONTINUE - ELSE IF( NDIGIT.LE.8 ) THEN - DO 50 K1 = 1, N, 2 - K2 = MIN0( N, K1+1 ) - IF (K1.NE.N) THEN - WRITE( LOUT, 9978 )K1, K2, ( CX( I ), - $ I = K1, K2 ) - ELSE - WRITE( LOUT, 9977 )K1, K2, ( CX( I ), - $ I = K1, K2 ) - END IF - 50 CONTINUE - ELSE - DO 60 K1 = 1, N - WRITE( LOUT, 9968 )K1, K1, CX( I ) - 60 CONTINUE - END IF -* -*======================================================================= -* CODE FOR OUTPUT USING 132 COLUMNS FORMAT -*======================================================================= -* - ELSE - IF( NDIGIT.LE.4 ) THEN - DO 70 K1 = 1, N, 4 - K2 = MIN0( N, K1+3 ) - IF ((K1+3).LE.N) THEN - WRITE( LOUT, 9958 )K1, K2, ( CX( I ), - $ I = K1, K2 ) - ELSE IF ((K1+3-N) .EQ. 1) THEN - WRITE( LOUT, 9957 )K1, K2, ( CX( I ), - $ I = K1, K2 ) - ELSE IF ((K1+3-N) .EQ. 2) THEN - WRITE( LOUT, 9956 )K1, K2, ( CX( I ), - $ I = K1, K2 ) - ELSE IF ((K1+3-N) .EQ. 1) THEN - WRITE( LOUT, 9955 )K1, K2, ( CX( I ), - $ I = K1, K2 ) - END IF - 70 CONTINUE - ELSE IF( NDIGIT.LE.6 ) THEN - DO 80 K1 = 1, N, 3 - K2 = MIN0( N, K1+2 ) - IF ((K1+2).LE.N) THEN - WRITE( LOUT, 9948 )K1, K2, ( CX( I ), - $ I = K1, K2 ) - ELSE IF ((K1+2-N) .EQ. 1) THEN - WRITE( LOUT, 9947 )K1, K2, ( CX( I ), - $ I = K1, K2 ) - ELSE IF ((K1+2-N) .EQ. 2) THEN - WRITE( LOUT, 9946 )K1, K2, ( CX( I ), - $ I = K1, K2 ) - END IF - 80 CONTINUE - ELSE IF( NDIGIT.LE.8 ) THEN - DO 90 K1 = 1, N, 3 - K2 = MIN0( N, K1+2 ) - IF ((K1+2).LE.N) THEN - WRITE( LOUT, 9938 )K1, K2, ( CX( I ), - $ I = K1, K2 ) - ELSE IF ((K1+2-N) .EQ. 1) THEN - WRITE( LOUT, 9937 )K1, K2, ( CX( I ), - $ I = K1, K2 ) - ELSE IF ((K1+2-N) .EQ. 2) THEN - WRITE( LOUT, 9936 )K1, K2, ( CX( I ), - $ I = K1, K2 ) - END IF - 90 CONTINUE - ELSE - DO 100 K1 = 1, N, 2 - K2 = MIN0( N, K1+1 ) - IF ((K1+2).LE.N) THEN - WRITE( LOUT, 9928 )K1, K2, ( CX( I ), - $ I = K1, K2 ) - ELSE IF ((K1+2-N) .EQ. 1) THEN - WRITE( LOUT, 9927 )K1, K2, ( CX( I ), - $ I = K1, K2 ) - END IF - 100 CONTINUE - END IF - END IF - WRITE( LOUT, 9994 ) - RETURN -* -*======================================================================= -* FORMAT FOR 72 COLUMNS -*======================================================================= -* -* DISPLAY 4 SIGNIFICANT DIGITS -* - 9998 FORMAT( 1X, I4, ' - ', I4, ':', 1X, - $ 1P,2('(',D10.3,',',D10.3,') ') ) - 9997 FORMAT( 1X, I4, ' - ', I4, ':', 1X, - $ 1P,1('(',D10.3,',',D10.3,') ') ) -* -* DISPLAY 6 SIGNIFICANT DIGITS -* - 9988 FORMAT( 1X, I4, ' - ', I4, ':', 1X, - $ 1P,2('(',D12.5,',',D12.5,') ') ) - 9987 FORMAT( 1X, I4, ' - ', I4, ':', 1X, - $ 1P,1('(',D12.5,',',D12.5,') ') ) -* -* DISPLAY 8 SIGNIFICANT DIGITS -* - 9978 FORMAT( 1X, I4, ' - ', I4, ':', 1X, - $ 1P,2('(',D14.7,',',D14.7,') ') ) - 9977 FORMAT( 1X, I4, ' - ', I4, ':', 1X, - $ 1P,1('(',D14.7,',',D14.7,') ') ) -* -* DISPLAY 13 SIGNIFICANT DIGITS -* - 9968 FORMAT( 1X, I4, ' - ', I4, ':', 1X, - $ 1P,1('(',D20.13,',',D20.13,') ') ) -* -*========================================================================= -* FORMAT FOR 132 COLUMNS -*========================================================================= -* -* DISPLAY 4 SIGNIFICANT DIGITS -* - 9958 FORMAT( 1X, I4, ' - ', I4, ':', 1X, - $ 1P,4('(',D10.3,',',D10.3,') ') ) - 9957 FORMAT( 1X, I4, ' - ', I4, ':', 1X, - $ 1P,3('(',D10.3,',',D10.3,') ') ) - 9956 FORMAT( 1X, I4, ' - ', I4, ':', 1X, - $ 1P,2('(',D10.3,',',D10.3,') ') ) - 9955 FORMAT( 1X, I4, ' - ', I4, ':', 1X, - $ 1P,1('(',D10.3,',',D10.3,') ') ) -* -* DISPLAY 6 SIGNIFICANT DIGITS -* - 9948 FORMAT( 1X, I4, ' - ', I4, ':', 1X, - $ 1P,3('(',D12.5,',',D12.5,') ') ) - 9947 FORMAT( 1X, I4, ' - ', I4, ':', 1X, - $ 1P,2('(',D12.5,',',D12.5,') ') ) - 9946 FORMAT( 1X, I4, ' - ', I4, ':', 1X, - $ 1P,1('(',D12.5,',',D12.5,') ') ) -* -* DISPLAY 8 SIGNIFICANT DIGITS -* - 9938 FORMAT( 1X, I4, ' - ', I4, ':', 1X, - $ 1P,3('(',D14.7,',',D14.7,') ') ) - 9937 FORMAT( 1X, I4, ' - ', I4, ':', 1X, - $ 1P,2('(',D14.7,',',D14.7,') ') ) - 9936 FORMAT( 1X, I4, ' - ', I4, ':', 1X, - $ 1P,1('(',D14.7,',',D14.7,') ') ) -* -* DISPLAY 13 SIGNIFICANT DIGITS -* - 9928 FORMAT( 1X, I4, ' - ', I4, ':', 1X, - $ 1P,2('(',D20.13,',',D20.13,') ') ) - 9927 FORMAT( 1X, I4, ' - ', I4, ':', 1X, - $ 1P,1('(',D20.13,',',D20.13,') ') ) -* -* -* - 9994 FORMAT( 1X, ' ' ) - END
--- a/liboctave/Array.cc Mon Jan 02 15:19:45 2012 -0500 +++ b/liboctave/Array.cc Fri Jan 06 12:43:48 2012 -0500 @@ -783,7 +783,7 @@ if (i.extent (r) != r) gripe_index_out_of_range (2, 1, i.extent (r), r); // throws if (j.extent (c) != c) - gripe_index_out_of_range (2, 2, i.extent (c), c); // throws + gripe_index_out_of_range (2, 2, j.extent (c), c); // throws octave_idx_type n = numel (), il = i.length (r), jl = j.length (c);
--- a/liboctave/dir-ops.cc Mon Jan 02 15:19:45 2012 -0500 +++ b/liboctave/dir-ops.cc Fri Jan 06 12:43:48 2012 -0500 @@ -77,7 +77,7 @@ struct dirent *dir_ent; - while ((dir_ent = readdir (static_cast<DIR *> (dir)))) + while ((dir_ent = gnulib::readdir (static_cast<DIR *> (dir)))) { if (dir_ent) dirlist.push_back (dir_ent->d_name);
--- a/liboctave/eigs-base.cc Mon Jan 02 15:19:45 2012 -0500 +++ b/liboctave/eigs-base.cc Fri Jan 06 12:43:48 2012 -0500 @@ -44,6 +44,7 @@ #include "dbleLU.h" #include "CmplxLU.h" +#ifdef HAVE_ARPACK typedef ColumnVector (*EigsFunc) (const ColumnVector &x, int &eigs_error); typedef ComplexColumnVector (*EigsComplexFunc) (const ComplexColumnVector &x, int &eigs_error); @@ -3829,6 +3830,7 @@ ComplexColumnVector &resid, std::ostream& os, double tol = DBL_EPSILON, bool rvec = false, bool cholB = 0, int disp = 0, int maxit = 300); +#endif #ifndef _MSC_VER template static octave_idx_type
--- a/liboctave/kpse.cc Mon Jan 02 15:19:45 2012 -0500 +++ b/liboctave/kpse.cc Fri Jan 06 12:43:48 2012 -0500 @@ -225,10 +225,6 @@ #define DEBUGF4(str, e1, e2, e3, e4) \ DEBUGF_START (); gnulib::fprintf (stderr, str, e1, e2, e3, e4); DEBUGF_END () -#undef fopen -#define fopen kpse_fopen_trace -static FILE *fopen (const char *filename, const char *mode); - #endif /* not NO_DEBUG */ #ifdef KPSE_DEBUG @@ -362,11 +358,15 @@ assert (! filename.empty () && mode); - f = fopen (filename.c_str (), mode); + f = gnulib::fopen (filename.c_str (), mode); if (! f) FATAL_PERROR (filename.c_str ()); + if (KPSE_DEBUG_P (KPSE_DEBUG_FOPEN)) + DEBUGF3 ("fopen (%s, %s) => 0x%lx\n", filename.c_str (), mode, + reinterpret_cast<unsigned long> (f)); + return f; } @@ -2282,7 +2282,7 @@ name.resize (elt_length); } - while ((e = readdir (dir))) + while ((e = gnulib::readdir (dir))) { /* If it begins with a `.', never mind. (This allows ``hidden'' directories that the algorithm won't find.) */ @@ -2446,28 +2446,6 @@ } #endif -/* Help the user discover what's going on. */ - -#ifdef KPSE_DEBUG - -/* If the real definitions of fopen or fclose are macros, we lose -- the - #undef won't restore them. */ - -static FILE * -fopen (const char *filename, const char *mode) -{ -#undef fopen - FILE *ret = fopen (filename, mode); - - if (KPSE_DEBUG_P (KPSE_DEBUG_FOPEN)) - DEBUGF3 ("fopen (%s, %s) => 0x%lx\n", filename, mode, - reinterpret_cast<unsigned long> (ret)); - - return ret; -} - -#endif - /* Implementation of a linked list of strings. */ /* Add the new string STR to the end of the list L. */
--- a/liboctave/lo-sysdep.cc Mon Jan 02 15:19:45 2012 -0500 +++ b/liboctave/lo-sysdep.cc Fri Jan 06 12:43:48 2012 -0500 @@ -77,7 +77,7 @@ path += "\\"; #endif - return chdir (path.c_str ()); + return gnulib::chdir (path.c_str ()); } #if defined (__WIN32__) && ! defined (__CYGWIN__) @@ -141,73 +141,3 @@ } #endif - -#if defined (_MSC_VER) && ! defined (HAVE_DIRENT_H) - -// FIXME -- it would probably be better to adapt the versions of -// opendir, readdir, and closedir from Emacs as they appear to be more -// complete implementations (do the functions below work for network -// paths, for example)? We can probably get along without rewinddir. - -struct __DIR -{ - HANDLE hnd; - WIN32_FIND_DATA fd; - int dirty; - struct direct d; - const char *current; -}; - -DIR * -opendir (const char *name) -{ - DIR *d = static_cast<DIR *> (malloc (sizeof (DIR))); - static char buffer[MAX_PATH]; - - strncpy (buffer, name, MAX_PATH); - if (buffer[strnlen(buffer, MAX_PATH)-1] != '\\') - strncat (buffer, "\\*", MAX_PATH); - else - strncat (buffer, "*", MAX_PATH); - d->current = buffer; - d->hnd = FindFirstFile (buffer, &(d->fd)); - if (d->hnd == INVALID_HANDLE_VALUE) - { - free (d); - return 0; - } - d->dirty = 1; - return d; -} - -void -rewinddir (DIR *d) -{ - if (d->hnd != INVALID_HANDLE_VALUE) - FindClose (d->hnd); - d->hnd = FindFirstFile (d->current, &(d->fd)); - d->dirty = 1; -} - -void -closedir (DIR *d) -{ - if (d->hnd != INVALID_HANDLE_VALUE) - FindClose (d->hnd); - free (d); -} - -struct direct * -readdir (DIR *d) -{ - if (! d->dirty) - { - if (! FindNextFile(d->hnd, &(d->fd))) - return 0; - } - d->d.d_name = d->fd.cFileName; - d->dirty = 0; - return &(d->d); -} - -#endif
--- a/liboctave/lo-sysdep.h Mon Jan 02 15:19:45 2012 -0500 +++ b/liboctave/lo-sysdep.h Fri Jan 06 12:43:48 2012 -0500 @@ -37,25 +37,4 @@ bool, int *, std::string&); #endif -#if defined (_MSC_VER) && ! defined (HAVE_DIRENT_H) - -// FIXME -- it would probably be better to adapt the versions of -// opendir, readdir, and closedir from Emacs as they appear to be more -// complete implementations. We can probably get along without -// rewinddir. - -struct direct -{ - char *d_name; -}; - -typedef struct __DIR DIR; - -extern DIR* opendir (const char *name); -extern void rewinddir (DIR *d); -extern void closedir (DIR *d); -extern struct direct *readdir (DIR *d); - #endif - -#endif
--- a/liboctave/oct-md5.cc Mon Jan 02 15:19:45 2012 -0500 +++ b/liboctave/oct-md5.cc Fri Jan 06 12:43:48 2012 -0500 @@ -62,7 +62,7 @@ { std::string retval; - FILE *ifile = fopen (file.c_str (), "rb"); + FILE *ifile = gnulib::fopen (file.c_str (), "rb"); if (ifile) {
--- a/m4/acinclude.m4 Mon Jan 02 15:19:45 2012 -0500 +++ b/m4/acinclude.m4 Fri Jan 06 12:43:48 2012 -0500 @@ -1015,6 +1015,156 @@ fi ]) dnl +dnl Check whether ARPACK works (does not crash) +dnl +dnl Using a pure Fortran program doesn't seem to crash when linked +dnl with the buggy ARPACK library but the C++ program does. Maybe +dnl it is the memory allocation that exposes the bug and using statically +dnl allocated arrays in Fortran does not? +dnl +AC_DEFUN([OCTAVE_CHECK_ARPACK_OK], [ + AC_LANG_PUSH(C++) + AC_CACHE_CHECK([whether the arpack library works], + [octave_cv_lib_arpack_ok], [ + AC_RUN_IFELSE([AC_LANG_PROGRAM([[ +// External functions from ARPACK library +extern "C" int +F77_FUNC (dnaupd, DNAUPD) (int&, const char *, const int&, const char *, + int&, const double&, double*, const int&, + double*, const int&, int*, int*, double*, + double*, const int&, int&, long int, long int); + +extern "C" int +F77_FUNC (dneupd, DNEUPD) (const int&, const char *, int*, double*, + double*, double*, const int&, + const double&, const double&, double*, + const char*, const int&, const char *, + int&, const double&, double*, const int&, + double*, const int&, int*, int*, double*, + double*, const int&, int&, long int, + long int, long int); + +extern "C" int +F77_FUNC (dgemv, DGEMV) (const char *, const int&, const int&, + const double&, const double*, const int&, + const double*, const int&, const double&, + double*, const int&, long int); + +#include <cfloat> + +void +doit (void) +{ + // Based on function EigsRealNonSymmetricMatrix from liboctave/eigs-base.cc. + + // Problem matrix. See bug #31479 + int n = 4; + double *m = new double [n * n]; + m[0] = 1, m[4] = 0, m[8] = 0, m[12] = -1; + m[1] = 0, m[5] = 1, m[9] = 0, m[13] = 0; + m[2] = 0, m[6] = 0, m[10] = 1, m[14] = 0; + m[3] = 0, m[7] = 0, m[11] = 2, m[15] = 1; + + double *resid = new double [4]; + + resid[0] = 0.960966; + resid[1] = 0.741195; + resid[2] = 0.150143; + resid[3] = 0.868067; + + int *ip = new int [11]; + + ip[0] = 1; // ishift + ip[1] = 0; // ip[1] not referenced + ip[2] = 300; // mxiter, maximum number of iterations + ip[3] = 1; // NB blocksize in recurrence + ip[4] = 0; // nconv, number of Ritz values that satisfy convergence + ip[5] = 0; // ip[5] not referenced + ip[6] = 1; // mode + ip[7] = 0; // ip[7] to ip[10] are return values + ip[8] = 0; + ip[9] = 0; + ip[10] = 0; + + int *ipntr = new int [14]; + + int k = 1; + int p = 3; + int lwork = 3 * p * (p + 2); + + double *v = new double [n * (p + 1)]; + double *workl = new double [lwork + 1]; + double *workd = new double [3 * n + 1]; + + int ido = 0; + int info = 0; + + double tol = DBL_EPSILON; + + do + { + F77_FUNC (dnaupd, DNAUPD) (ido, "I", n, "LM", k, tol, resid, p, + v, n, ip, ipntr, workd, workl, lwork, + info, 1L, 2L); + + if (ido == -1 || ido == 1 || ido == 2) + { + double *x = workd + ipntr[0] - 1; + double *y = workd + ipntr[1] - 1; + + F77_FUNC (dgemv, DGEMV) ("N", n, n, 1.0, m, n, x, 1, 0.0, + y, 1, 1L); + } + else + { + if (info < 0) + { + return; // Error + } + + break; + } + } + while (1); + + int *sel = new int [p]; + + // In Octave, the dimensions of dr and di are k+1, but k+2 avoids segfault + double *dr = new double [k + 1]; + double *di = new double [k + 1]; + double *workev = new double [3 * p]; + + for (int i = 0; i < k + 1; i++) + dr[i] = di[i] = 0.; + + int rvec = 1; + + double sigmar = 0.0; + double sigmai = 0.0; + + // In Octave, this is n*(k+1), but k+2 avoids segfault + double *z = new double [n * (k + 1)]; + + F77_FUNC (dneupd, DNEUPD) (rvec, "A", sel, dr, di, z, n, sigmar, + sigmai, workev, "I", n, "LM", k, tol, + resid, p, v, n, ip, ipntr, workd, + workl, lwork, info, 1L, 1L, 2L); +} +]], [[ + for (int i = 0; i < 10; i++) + doit (); +]])], + [octave_cv_lib_arpack_ok=yes], + [octave_cv_lib_arpack_ok=no], + [octave_cv_lib_arpack_ok=yes])]) + AC_LANG_POP(C++) + if test "$octave_cv_lib_arpack_ok" = "yes"; then + $1 + else + $2 + fi +]) +dnl dnl Check for OpenGL. If found, define OPENGL_LIBS dnl dnl FIXME -- the following tests should probably check for the
--- a/scripts/optimization/fsolve.m Mon Jan 02 15:19:45 2012 -0500 +++ b/scripts/optimization/fsolve.m Fri Jan 06 12:43:48 2012 -0500 @@ -86,7 +86,6 @@ ## ## Note: If you only have a single nonlinear equation of one variable, using ## @code{fzero} is usually a much better idea. -## @seealso{fzero, optimset} ## ## Note about user-supplied Jacobians: ## As an inherent property of the algorithm, Jacobian is always requested for a @@ -121,10 +120,11 @@ ## endif ## endfunction ## -## ## @dots{}. +## ## @dots{} ## ## fsolve (@@user_func, x0, optimset ("OutputFcn", @@user_func, @dots{})) ## @end example +## @seealso{fzero, optimset} ## @end deftypefn ## PKG_ADD: ## Discard result to avoid polluting workspace with ans at startup.
--- a/scripts/set/intersect.m Mon Jan 02 15:19:45 2012 -0500 +++ b/scripts/set/intersect.m Fri Jan 06 12:43:48 2012 -0500 @@ -57,6 +57,7 @@ [c, ic] = sortrows (c); ii = find (all (c(1:end-1,:) == c(2:end,:), 2)); c = c(ii,:); + len_a = rows (a); else c = [a(:); b(:)]; [c, ic] = sort (c); ## [a(:);b(:)](ic) == c @@ -66,11 +67,12 @@ ii = find (c(1:end-1) == c(2:end)); endif c = c(ii); + len_a = length (a); endif if (nargout > 1) ia = ja(ic(ii)); ## a(ia) == c - ib = jb(ic(ii+1) - length (a)); ## b(ib) == c + ib = jb(ic(ii+1) - len_a); ## b(ib) == c endif if (nargin == 2 && (size (b, 1) == 1 || size (a, 1) == 1)) @@ -105,3 +107,9 @@ %! b = [1 2 3 4 5 6]; %! c = intersect(a,b); %! assert(c, [1,2]); +%!test +%! a = [1 2 3 4; 5 6 7 8; 9 10 11 12]; +%! [b, ia, ib] = intersect(a, a, "rows"); +%! assert(b, a); +%! assert(ia, [1:3]'); +%! assert(ib, [1:3]');
--- a/scripts/sparse/svds.m Mon Jan 02 15:19:45 2012 -0500 +++ b/scripts/sparse/svds.m Fri Jan 06 12:43:48 2012 -0500 @@ -258,7 +258,7 @@ %! opts.v0 = rand (2*n,1); % Initialize eigs ARPACK starting vector %! % to guarantee reproducible results %! -%!test +%!testif HAVE_ARPACK %! [u2,s2,v2,flag] = svds (A,k); %! s2 = diag (s2); %! assert (flag, !1); @@ -279,13 +279,13 @@ %! assert (flag, !1); %! assert (s2, s((idx+floor(k/2)):-1:(idx-floor(k/2))), 1e-10); %! -%!test +%!testif HAVE_ARPACK %! [u2,s2,v2,flag] = svds (zeros (10), k); %! assert (u2, eye (10, k)); %! assert (s2, zeros (k)); %! assert (v2, eye (10, 7)); %! -%!test +%!testif HAVE_ARPACK %! s = svds (speye (10)); %! assert (s, ones (6, 1), 2*eps);
--- a/src/DLD-FUNCTIONS/eigs.cc Mon Jan 02 15:19:45 2012 -0500 +++ b/src/DLD-FUNCTIONS/eigs.cc Fri Jan 06 12:43:48 2012 -0500 @@ -304,7 +304,7 @@ @end deftypefn") { octave_value_list retval; - +#ifdef HAVE_ARPACK int nargin = args.length (); std::string fcn_name; octave_idx_type n = 0; @@ -759,6 +759,9 @@ if (! fcn_name.empty ()) clear_function (fcn_name); +#else + error ("eigs: not available in this version of Octave"); +#endif return retval; } @@ -777,28 +780,28 @@ %! [~, idx] = sort (abs(d0)); %! d0 = d0(idx); %! rand("state", 42); % initialize generator to make eigs behavior reproducible -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A, k); %! assert (d1, d0(end:-1:(end-k+1)), 1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A,k+1); %! assert (d1, d0(end:-1:(end-k)),1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A, k, 'lm'); %! assert (d1, d0(end:-1:(end-k+1)), 1e-11); %!testif HAVE_UMFPACK %! d1 = eigs (A, k, 'sm'); %! assert (d1, d0(k:-1:1), 1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A, k, 'la'); %! assert (d1, d2(end:-1:(end-k+1)), 1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A, k, 'sa'); %! assert (d1, d2(1:k), 1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A, k, 'be'); %! assert (d1, d2([1:floor(k/2), (end - ceil(k/2) + 1):end]), 1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A, k+1, 'be'); %! assert (d1, d2([1:floor((k+1)/2), (end - ceil((k+1)/2) + 1):end]), 1e-11); %!testif HAVE_UMFPACK @@ -811,11 +814,11 @@ %! assert (abs(d1), abs(d0(end:-1:(end-k+1))), 1e-11); %!testif HAVE_UMFPACK %! assert (eigs(A,k,4.1), eigs(A,speye(n),k,4.1), 1e-11); -%!test +%!testif HAVE_ARPACK %! opts.cholB=true; %! d1 = eigs(A, speye(n), k, 'lm', opts); %! assert (abs(d1), abs(d0(end:-1:(end-k+1))), 1e-11); -%!test +%!testif HAVE_ARPACK %! opts.cholB=true; %! q = [2:n,1]; %! opts.permB=q; @@ -833,12 +836,12 @@ %! assert (abs(d1), eigs(A,k,4.1), 1e-11); %!testif HAVE_UMFPACK %! assert (eigs(A,k,4.1), eigs(A,speye(n),k,4.1), 1e-11); -%!test +%!testif HAVE_ARPACK %! fn = @(x) A * x; %! opts.issym = 1; opts.isreal = 1; %! d1 = eigs (fn, n, k, 'lm', opts); %! assert (d1, d0(end:-1:(end-k+1)), 1e-11); -%!test +%!testif HAVE_ARPACK %! fn = @(x) A \ x; %! opts.issym = 1; opts.isreal = 1; %! d1 = eigs (fn, n, k, 'sm', opts); @@ -848,12 +851,12 @@ %! opts.issym = 1; opts.isreal = 1; %! d1 = eigs (fn, n, k, 4.1, opts); %! assert (d1, eigs(A,k,4.1), 1e-11); -%!test +%!testif HAVE_ARPACK %! AA = speye (10); %! fn = @(x) AA * x; %! opts.issym = 1; opts.isreal = 1; %! assert (eigs (fn, 10, AA, 3, 'lm', opts), [1; 1; 1],10*eps); -%!test +%!testif HAVE_ARPACK %! [v1,d1] = eigs(A, k, 'lm'); %! d1 = diag(d1); %! for i=1:k @@ -865,19 +868,19 @@ %! for i=1:k %! assert(max(abs((A - d1(i)*speye(n))*v1(:,i))),0.,1e-11) %! endfor -%!test +%!testif HAVE_ARPACK %! [v1,d1] = eigs(A, k, 'la'); %! d1 = diag(d1); %! for i=1:k %! assert(max(abs((A - d1(i)*speye(n))*v1(:,i))),0.,1e-11) %! endfor -%!test +%!testif HAVE_ARPACK %! [v1,d1] = eigs(A, k, 'sa'); %! d1 = diag(d1); %! for i=1:k %! assert(max(abs((A - d1(i)*speye(n))*v1(:,i))),0.,1e-11) %! endfor -%!test +%!testif HAVE_ARPACK %! [v1,d1] = eigs(A, k, 'be'); %! d1 = diag(d1); %! for i=1:k @@ -897,34 +900,34 @@ %! [~, idx] = sort (abs(d0)); %! d0 = d0(idx); %! rand("state", 42); % initialize generator to make eigs behavior reproducible -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A, k); %! assert (abs(d1), abs(d0(end:-1:(end-k+1))), 1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A,k+1); %! assert (abs(d1), abs(d0(end:-1:(end-k))),1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A, k, 'lm'); %! assert (abs(d1), abs(d0(end:-1:(end-k+1))), 1e-11); %!testif HAVE_UMFPACK %! d1 = eigs (A, k, 'sm'); %! assert (abs(d1), abs(d0(1:k)), 1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A, k, 'lr'); %! [~, idx] = sort (real(d0)); %! d2 = d0(idx); %! assert (real(d1), real(d2(end:-1:(end-k+1))), 1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A, k, 'sr'); %! [~, idx] = sort (real(abs(d0))); %! d2 = d0(idx); %! assert (real(d1), real(d2(1:k)), 1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A, k, 'li'); %! [~, idx] = sort (imag(abs(d0))); %! d2 = d0(idx); %! assert (sort(imag(d1)), sort(imag(d2(end:-1:(end-k+1)))), 1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A, k, 'si'); %! [~, idx] = sort (imag(abs(d0))); %! d2 = d0(idx); @@ -938,11 +941,11 @@ %!testif HAVE_CHOLMOD %! d1 = eigs(A, speye(n), k, 'lm'); %! assert (abs(d1), abs(d0(end:-1:(end-k+1))), 1e-11); -%!test +%!testif HAVE_ARPACK %! opts.cholB=true; %! d1 = eigs(A, speye(n), k, 'lm', opts); %! assert (abs(d1), abs(d0(end:-1:(end-k+1))), 1e-11); -%!test +%!testif HAVE_ARPACK %! opts.cholB=true; %! q = [2:n,1]; %! opts.permB=q; @@ -962,12 +965,12 @@ %! assert (abs(eigs(A,k,4.1)), abs(eigs(A,speye(n),k,4.1)), 1e-11); %!testif HAVE_UMFPACK %! assert (sort(imag(eigs(A,k,4.1))), sort(imag(eigs(A,speye(n),k,4.1))), 1e-11); -%!test +%!testif HAVE_ARPACK %! fn = @(x) A * x; %! opts.issym = 0; opts.isreal = 1; %! d1 = eigs (fn, n, k, 'lm', opts); %! assert (abs(d1), abs(d0(end:-1:(end-k+1))), 1e-11); -%!test +%!testif HAVE_ARPACK %! fn = @(x) A \ x; %! opts.issym = 0; opts.isreal = 1; %! d1 = eigs (fn, n, k, 'sm', opts); @@ -977,7 +980,7 @@ %! opts.issym = 0; opts.isreal = 1; %! d1 = eigs (fn, n, k, 4.1, opts); %! assert (abs(d1), eigs(A,k,4.1), 1e-11); -%!test +%!testif HAVE_ARPACK %! [v1,d1] = eigs(A, k, 'lm'); %! d1 = diag(d1); %! for i=1:k @@ -989,25 +992,25 @@ %! for i=1:k %! assert(max(abs((A - d1(i)*speye(n))*v1(:,i))),0.,1e-11) %! endfor -%!test +%!testif HAVE_ARPACK %! [v1,d1] = eigs(A, k, 'lr'); %! d1 = diag(d1); %! for i=1:k %! assert(max(abs((A - d1(i)*speye(n))*v1(:,i))),0.,1e-11) %! endfor -%!test +%!testif HAVE_ARPACK %! [v1,d1] = eigs(A, k, 'sr'); %! d1 = diag(d1); %! for i=1:k %! assert(max(abs((A - d1(i)*speye(n))*v1(:,i))),0.,1e-11) %! endfor -%!test +%!testif HAVE_ARPACK %! [v1,d1] = eigs(A, k, 'li'); %! d1 = diag(d1); %! for i=1:k %! assert(max(abs((A - d1(i)*speye(n))*v1(:,i))),0.,1e-11) %! endfor -%!test +%!testif HAVE_ARPACK %! [v1,d1] = eigs(A, k, 'si'); %! d1 = diag(d1); %! for i=1:k @@ -1027,34 +1030,34 @@ %! [~, idx] = sort (abs(d0)); %! d0 = d0(idx); %! rand("state", 42); % initialize generator to make eigs behavior reproducible -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A, k); %! assert (abs(d1), abs(d0(end:-1:(end-k+1))), 1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A,k+1); %! assert (abs(d1), abs(d0(end:-1:(end-k))),1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A, k, 'lm'); %! assert (abs(d1), abs(d0(end:-1:(end-k+1))), 1e-11); %!testif HAVE_UMFPACK %! d1 = eigs (A, k, 'sm'); %! assert (abs(d1), abs(d0(1:k)), 1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A, k, 'lr'); %! [~, idx] = sort (real(abs(d0))); %! d2 = d0(idx); %! assert (real(d1), real(d2(end:-1:(end-k+1))), 1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A, k, 'sr'); %! [~, idx] = sort (real(abs(d0))); %! d2 = d0(idx); %! assert (real(d1), real(d2(1:k)), 1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A, k, 'li'); %! [~, idx] = sort (imag(abs(d0))); %! d2 = d0(idx); %! assert (sort(imag(d1)), sort(imag(d2(end:-1:(end-k+1)))), 1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A, k, 'si'); %! [~, idx] = sort (imag(abs(d0))); %! d2 = d0(idx); @@ -1068,11 +1071,11 @@ %!testif HAVE_CHOLMOD %! d1 = eigs(A, speye(n), k, 'lm'); %! assert (abs(d1), abs(d0(end:-1:(end-k+1))), 1e-11); -%!test +%!testif HAVE_ARPACK %! opts.cholB=true; %! d1 = eigs(A, speye(n), k, 'lm', opts); %! assert (abs(d1), abs(d0(end:-1:(end-k+1))), 1e-11); -%!test +%!testif HAVE_ARPACK %! opts.cholB=true; %! q = [2:n,1]; %! opts.permB=q; @@ -1094,12 +1097,12 @@ %! assert (abs(eigs(A,k,4.1)), abs(eigs(A,speye(n),k,4.1)), 1e-11); %!testif HAVE_UMFPACK %! assert (sort(imag(eigs(A,k,4.1))), sort(imag(eigs(A,speye(n),k,4.1))), 1e-11); -%!test +%!testif HAVE_ARPACK %! fn = @(x) A * x; %! opts.issym = 0; opts.isreal = 0; %! d1 = eigs (fn, n, k, 'lm', opts); %! assert (abs(d1), abs(d0(end:-1:(end-k+1))), 1e-11); -%!test +%!testif HAVE_ARPACK %! fn = @(x) A \ x; %! opts.issym = 0; opts.isreal = 0; %! d1 = eigs (fn, n, k, 'sm', opts); @@ -1109,7 +1112,7 @@ %! opts.issym = 0; opts.isreal = 0; %! d1 = eigs (fn, n, k, 4.1, opts); %! assert (abs(d1), eigs(A,k,4.1), 1e-11); -%!test +%!testif HAVE_ARPACK %! [v1,d1] = eigs(A, k, 'lm'); %! d1 = diag(d1); %! for i=1:k @@ -1121,25 +1124,25 @@ %! for i=1:k %! assert(max(abs((A - d1(i)*speye(n))*v1(:,i))),0.,1e-11) %! endfor -%!test +%!testif HAVE_ARPACK %! [v1,d1] = eigs(A, k, 'lr'); %! d1 = diag(d1); %! for i=1:k %! assert(max(abs((A - d1(i)*speye(n))*v1(:,i))),0.,1e-11) %! endfor -%!test +%!testif HAVE_ARPACK %! [v1,d1] = eigs(A, k, 'sr'); %! d1 = diag(d1); %! for i=1:k %! assert(max(abs((A - d1(i)*speye(n))*v1(:,i))),0.,1e-11) %! endfor -%!test +%!testif HAVE_ARPACK %! [v1,d1] = eigs(A, k, 'li'); %! d1 = diag(d1); %! for i=1:k %! assert(max(abs((A - d1(i)*speye(n))*v1(:,i))),0.,1e-11) %! endfor -%!test +%!testif HAVE_ARPACK %! [v1,d1] = eigs(A, k, 'si'); %! d1 = diag(d1); %! for i=1:k @@ -1162,102 +1165,102 @@ %! [~, idx] = sort (abs(d0)); %! d0 = d0(idx); %! rand("state", 42); % initialize generator to make eigs behavior reproducible -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A, k); %! assert (d1, d0(end:-1:(end-k+1)), 1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A,k+1); %! assert (d1, d0(end:-1:(end-k)),1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A, k, 'lm'); %! assert (d1, d0(end:-1:(end-k+1)), 1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A, k, 'sm'); %! assert (d1, d0(k:-1:1), 1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A, k, 'la'); %! assert (d1, d2(end:-1:(end-k+1)), 1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A, k, 'sa'); %! assert (d1, d2(1:k), 1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A, k, 'be'); %! assert (d1, d2([1:floor(k/2), (end - ceil(k/2) + 1):end]), 1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A, k+1, 'be'); %! assert (d1, d2([1:floor((k+1)/2), (end - ceil((k+1)/2) + 1):end]), 1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A, k, 4.1); %! [~,idx0] = sort (abs(d0 - 4.1)); %! [~,idx1] = sort (abs(d1 - 4.1)); %! assert (d1(idx1), d0(idx0(1:k)), 1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs(A, eye(n), k, 'lm'); %! assert (abs(d1), abs(d0(end:-1:(end-k+1))), 1e-11); -%!test +%!testif HAVE_ARPACK %! assert (eigs(A,k,4.1), eigs(A,eye(n),k,4.1), 1e-11); -%!test +%!testif HAVE_ARPACK %! opts.cholB=true; %! d1 = eigs(A, eye(n), k, 'lm', opts); %! assert (abs(d1), abs(d0(end:-1:(end-k+1))), 1e-11); -%!test +%!testif HAVE_ARPACK %! opts.cholB=true; %! q = [2:n,1]; %! opts.permB=q; %! d1 = eigs(A, eye(n)(q,q), k, 'lm', opts); %! assert (abs(d1), abs(d0(end:-1:(end-k+1))), 1e-11); -%!test +%!testif HAVE_ARPACK %! opts.cholB=true; %! d1 = eigs(A, eye(n), k, 4.1, opts); %! assert (abs(d1), eigs(A,k,4.1), 1e-11); -%!test +%!testif HAVE_ARPACK %! opts.cholB=true; %! q = [2:n,1]; %! opts.permB=q; %! d1 = eigs(A, eye(n)(q,q), k, 4.1, opts); %! assert (abs(d1), eigs(A,k,4.1), 1e-11); -%!test +%!testif HAVE_ARPACK %! assert (eigs(A,k,4.1), eigs(A,eye(n),k,4.1), 1e-11); -%!test +%!testif HAVE_ARPACK %! fn = @(x) A * x; %! opts.issym = 1; opts.isreal = 1; %! d1 = eigs (fn, n, k, 'lm', opts); %! assert (d1, d0(end:-1:(end-k+1)), 1e-11); -%!test +%!testif HAVE_ARPACK %! fn = @(x) A \ x; %! opts.issym = 1; opts.isreal = 1; %! d1 = eigs (fn, n, k, 'sm', opts); %! assert (d1, d0(k:-1:1), 1e-11); -%!test +%!testif HAVE_ARPACK %! fn = @(x) (A - 4.1 * eye(n)) \ x; %! opts.issym = 1; opts.isreal = 1; %! d1 = eigs (fn, n, k, 4.1, opts); %! assert (d1, eigs(A,k,4.1), 1e-11); -%!test +%!testif HAVE_ARPACK %! [v1,d1] = eigs(A, k, 'lm'); %! d1 = diag(d1); %! for i=1:k %! assert(max(abs((A - d1(i)*eye(n))*v1(:,i))),0.,1e-11) %! endfor -%!test +%!testif HAVE_ARPACK %! [v1,d1] = eigs(A, k, 'sm'); %! d1 = diag(d1); %! for i=1:k %! assert(max(abs((A - d1(i)*eye(n))*v1(:,i))),0.,1e-11) %! endfor -%!test +%!testif HAVE_ARPACK %! [v1,d1] = eigs(A, k, 'la'); %! d1 = diag(d1); %! for i=1:k %! assert(max(abs((A - d1(i)*eye(n))*v1(:,i))),0.,1e-11) %! endfor -%!test +%!testif HAVE_ARPACK %! [v1,d1] = eigs(A, k, 'sa'); %! d1 = diag(d1); %! for i=1:k %! assert(max(abs((A - d1(i)*eye(n))*v1(:,i))),0.,1e-11) %! endfor -%!test +%!testif HAVE_ARPACK %! [v1,d1] = eigs(A, k, 'be'); %! d1 = diag(d1); %! for i=1:k @@ -1277,117 +1280,117 @@ %! [~, idx] = sort (abs(d0)); %! d0 = d0(idx); %! rand("state", 42); % initialize generator to make eigs behavior reproducible -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A, k); %! assert (abs(d1), abs(d0(end:-1:(end-k+1))), 1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A,k+1); %! assert (abs(d1), abs(d0(end:-1:(end-k))),1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A, k, 'lm'); %! assert (abs(d1), abs(d0(end:-1:(end-k+1))), 1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A, k, 'sm'); %! assert (abs(d1), abs(d0(1:k)), 1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A, k, 'lr'); %! [~, idx] = sort (real(d0)); %! d2 = d0(idx); %! assert (real(d1), real(d2(end:-1:(end-k+1))), 1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A, k, 'sr'); %! [~, idx] = sort (real(abs(d0))); %! d2 = d0(idx); %! assert (real(d1), real(d2(1:k)), 1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A, k, 'li'); %! [~, idx] = sort (imag(abs(d0))); %! d2 = d0(idx); %! assert (sort(imag(d1)), sort(imag(d2(end:-1:(end-k+1)))), 1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A, k, 'si'); %! [~, idx] = sort (imag(abs(d0))); %! d2 = d0(idx); %! assert (sort(imag(d1)), sort(imag(d2(1:k))), 1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A, k, 4.1); %! [~,idx0] = sort (abs(d0 - 4.1)); %! [~,idx1] = sort (abs(d1 - 4.1)); %! assert (abs(d1(idx1)), abs(d0(idx0(1:k))), 1e-11); %! assert (sort(imag(d1(idx1))), sort(imag(d0(idx0(1:k)))), 1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs(A, eye(n), k, 'lm'); %! assert (abs(d1), abs(d0(end:-1:(end-k+1))), 1e-11); -%!test +%!testif HAVE_ARPACK %! opts.cholB=true; %! d1 = eigs(A, eye(n), k, 'lm', opts); %! assert (abs(d1), abs(d0(end:-1:(end-k+1))), 1e-11); -%!test +%!testif HAVE_ARPACK %! opts.cholB=true; %! q = [2:n,1]; %! opts.permB=q; %! d1 = eigs(A, eye(n)(q,q), k, 'lm', opts); %! assert (abs(d1), abs(d0(end:-1:(end-k+1))), 1e-11); -%!test +%!testif HAVE_ARPACK %! opts.cholB=true; %! d1 = eigs(A, eye(n), k, 4.1, opts); %! assert (abs(d1), eigs(A,k,4.1), 1e-11); -%!test +%!testif HAVE_ARPACK %! opts.cholB=true; %! q = [2:n,1]; %! opts.permB=q; %! d1 = eigs(A, eye(n)(q,q), k, 4.1, opts); %! assert (abs(d1), eigs(A,k,4.1), 1e-11); -%!test +%!testif HAVE_ARPACK %! assert (abs(eigs(A,k,4.1)), abs(eigs(A,eye(n),k,4.1)), 1e-11); -%!test +%!testif HAVE_ARPACK %! assert (sort(imag(eigs(A,k,4.1))), sort(imag(eigs(A,eye(n),k,4.1))), 1e-11); -%!test +%!testif HAVE_ARPACK %! fn = @(x) A * x; %! opts.issym = 0; opts.isreal = 1; %! d1 = eigs (fn, n, k, 'lm', opts); %! assert (abs(d1), abs(d0(end:-1:(end-k+1))), 1e-11); -%!test +%!testif HAVE_ARPACK %! fn = @(x) A \ x; %! opts.issym = 0; opts.isreal = 1; %! d1 = eigs (fn, n, k, 'sm', opts); %! assert (abs(d1), d0(1:k), 1e-11); -%!test +%!testif HAVE_ARPACK %! fn = @(x) (A - 4.1 * eye(n)) \ x; %! opts.issym = 0; opts.isreal = 1; %! d1 = eigs (fn, n, k, 4.1, opts); %! assert (abs(d1), eigs(A,k,4.1), 1e-11); -%!test +%!testif HAVE_ARPACK %! [v1,d1] = eigs(A, k, 'lm'); %! d1 = diag(d1); %! for i=1:k %! assert(max(abs((A - d1(i)*eye(n))*v1(:,i))),0.,1e-11) %! endfor -%!test +%!testif HAVE_ARPACK %! [v1,d1] = eigs(A, k, 'sm'); %! d1 = diag(d1); %! for i=1:k %! assert(max(abs((A - d1(i)*eye(n))*v1(:,i))),0.,1e-11) %! endfor -%!test +%!testif HAVE_ARPACK %! [v1,d1] = eigs(A, k, 'lr'); %! d1 = diag(d1); %! for i=1:k %! assert(max(abs((A - d1(i)*eye(n))*v1(:,i))),0.,1e-11) %! endfor -%!test +%!testif HAVE_ARPACK %! [v1,d1] = eigs(A, k, 'sr'); %! d1 = diag(d1); %! for i=1:k %! assert(max(abs((A - d1(i)*eye(n))*v1(:,i))),0.,1e-11) %! endfor -%!test +%!testif HAVE_ARPACK %! [v1,d1] = eigs(A, k, 'li'); %! d1 = diag(d1); %! for i=1:k %! assert(max(abs((A - d1(i)*eye(n))*v1(:,i))),0.,1e-11) %! endfor -%!test +%!testif HAVE_ARPACK %! [v1,d1] = eigs(A, k, 'si'); %! d1 = diag(d1); %! for i=1:k @@ -1407,119 +1410,119 @@ %! [~, idx] = sort (abs(d0)); %! d0 = d0(idx); %! rand("state", 42); % initialize generator to make eigs behavior reproducible -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A, k); %! assert (abs(d1), abs(d0(end:-1:(end-k+1))), 1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A,k+1); %! assert (abs(d1), abs(d0(end:-1:(end-k))),1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A, k, 'lm'); %! assert (abs(d1), abs(d0(end:-1:(end-k+1))), 1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A, k, 'sm'); %! assert (abs(d1), abs(d0(1:k)), 1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A, k, 'lr'); %! [~, idx] = sort (real(abs(d0))); %! d2 = d0(idx); %! assert (real(d1), real(d2(end:-1:(end-k+1))), 1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A, k, 'sr'); %! [~, idx] = sort (real(abs(d0))); %! d2 = d0(idx); %! assert (real(d1), real(d2(1:k)), 1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A, k, 'li'); %! [~, idx] = sort (imag(abs(d0))); %! d2 = d0(idx); %! assert (sort(imag(d1)), sort(imag(d2(end:-1:(end-k+1)))), 1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A, k, 'si'); %! [~, idx] = sort (imag(abs(d0))); %! d2 = d0(idx); %! assert (sort(imag(d1)), sort(imag(d2(1:k))), 1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs (A, k, 4.1); %! [~,idx0] = sort (abs(d0 - 4.1)); %! [~,idx1] = sort (abs(d1 - 4.1)); %! assert (abs(d1(idx1)), abs(d0(idx0(1:k))), 1e-11); %! assert (sort(imag(d1(idx1))), sort(imag(d0(idx0(1:k)))), 1e-11); -%!test +%!testif HAVE_ARPACK %! d1 = eigs(A, eye(n), k, 'lm'); %! assert (abs(d1), abs(d0(end:-1:(end-k+1))), 1e-11); -%!test +%!testif HAVE_ARPACK %! opts.cholB=true; %! d1 = eigs(A, eye(n), k, 'lm', opts); %! assert (abs(d1), abs(d0(end:-1:(end-k+1))), 1e-11); -%!test +%!testif HAVE_ARPACK %! opts.cholB=true; %! q = [2:n,1]; %! opts.permB=q; %! d1 = eigs(A, eye(n)(q,q), k, 'lm', opts); %! assert (abs(d1), abs(d0(end:-1:(end-k+1))), 1e-11); -%!test +%!testif HAVE_ARPACK %! opts.cholB=true; %! d1 = eigs(A, eye(n), k, 4.1, opts); %! assert (abs(abs(d1)), abs(eigs(A,k,4.1)), 1e-11); %! assert (sort(imag(abs(d1))), sort(imag(eigs(A,k,4.1))), 1e-11); -%!test +%!testif HAVE_ARPACK %! opts.cholB=true; %! q = [2:n,1]; %! opts.permB=q; %! d1 = eigs(A, eye(n)(q,q), k, 4.1, opts); %! assert (abs(abs(d1)), abs(eigs(A,k,4.1)), 1e-11); %! assert (sort(imag(abs(d1))), sort(imag(eigs(A,k,4.1))), 1e-11); -%!test +%!testif HAVE_ARPACK %! assert (abs(eigs(A,k,4.1)), abs(eigs(A,eye(n),k,4.1)), 1e-11); -%!test +%!testif HAVE_ARPACK %! assert (sort(imag(eigs(A,k,4.1))), sort(imag(eigs(A,eye(n),k,4.1))), 1e-11); -%!test +%!testif HAVE_ARPACK %! fn = @(x) A * x; %! opts.issym = 0; opts.isreal = 0; %! d1 = eigs (fn, n, k, 'lm', opts); %! assert (abs(d1), abs(d0(end:-1:(end-k+1))), 1e-11); -%!test +%!testif HAVE_ARPACK %! fn = @(x) A \ x; %! opts.issym = 0; opts.isreal = 0; %! d1 = eigs (fn, n, k, 'sm', opts); %! assert (abs(d1), d0(1:k), 1e-11); -%!test +%!testif HAVE_ARPACK %! fn = @(x) (A - 4.1 * eye(n)) \ x; %! opts.issym = 0; opts.isreal = 0; %! d1 = eigs (fn, n, k, 4.1, opts); %! assert (abs(d1), eigs(A,k,4.1), 1e-11); -%!test +%!testif HAVE_ARPACK %! [v1,d1] = eigs(A, k, 'lm'); %! d1 = diag(d1); %! for i=1:k %! assert(max(abs((A - d1(i)*eye(n))*v1(:,i))),0.,1e-11) %! endfor -%!test +%!testif HAVE_ARPACK %! [v1,d1] = eigs(A, k, 'sm'); %! d1 = diag(d1); %! for i=1:k %! assert(max(abs((A - d1(i)*eye(n))*v1(:,i))),0.,1e-11) %! endfor -%!test +%!testif HAVE_ARPACK %! [v1,d1] = eigs(A, k, 'lr'); %! d1 = diag(d1); %! for i=1:k %! assert(max(abs((A - d1(i)*eye(n))*v1(:,i))),0.,1e-11) %! endfor -%!test +%!testif HAVE_ARPACK %! [v1,d1] = eigs(A, k, 'sr'); %! d1 = diag(d1); %! for i=1:k %! assert(max(abs((A - d1(i)*eye(n))*v1(:,i))),0.,1e-11) %! endfor -%!test +%!testif HAVE_ARPACK %! [v1,d1] = eigs(A, k, 'li'); %! d1 = diag(d1); %! for i=1:k %! assert(max(abs((A - d1(i)*eye(n))*v1(:,i))),0.,1e-11) %! endfor -%!test +%!testif HAVE_ARPACK %! [v1,d1] = eigs(A, k, 'si'); %! d1 = diag(d1); %! for i=1:k
--- a/src/DLD-FUNCTIONS/quadcc.cc Mon Jan 02 15:19:45 2012 -0500 +++ b/src/DLD-FUNCTIONS/quadcc.cc Fri Jan 06 12:43:48 2012 -0500 @@ -31,11 +31,6 @@ #include "parse.h" #include "ov-fcn-handle.h" -#if ! defined (HAVE_COPYSIGN) && defined (HAVE__COPYSIGN) -#define copysign _copysign -#define HAVE_COPYSIGN 1 -#endif - /* Define the size of the interval heap. */ #define cquad_heapsize 200 @@ -1655,7 +1650,7 @@ wrap = true; for (i = 0; i <= nivals; i++) if (xisinf (iivals[i])) - iivals[i] = copysign (1.0, iivals[i]); + iivals[i] = gnulib::copysign (1.0, iivals[i]); else iivals[i] = 2.0 * atan (iivals[i]) / M_PI; } @@ -2020,7 +2015,7 @@ && ivl->c[0] / iv->c[0] > 2); if (ivl->ndiv > ndiv_max && 2 * ivl->ndiv > ivl->rdepth) { - igral = copysign (octave_Inf, igral); + igral = gnulib::copysign (octave_Inf, igral); warning ("quadcc: divergent integral detected"); break; } @@ -2116,7 +2111,7 @@ && ivr->c[0] / iv->c[0] > 2); if (ivr->ndiv > ndiv_max && 2 * ivr->ndiv > ivr->rdepth) { - igral = copysign (octave_Inf, igral); + igral = gnulib::copysign (octave_Inf, igral); warning ("quadcc: divergent integral detected"); break; }
--- a/src/lex.ll Mon Jan 02 15:19:45 2012 -0500 +++ b/src/lex.ll Fri Jan 06 12:43:48 2012 -0500 @@ -83,6 +83,7 @@ // via the gnulib namespace. #define fprintf GNULIB_NAMESPACE::fprintf #define fwrite GNULIB_NAMESPACE::fwrite +#define isatty GNULIB_NAMESPACE::isatty #define malloc GNULIB_NAMESPACE::malloc #define realloc GNULIB_NAMESPACE::realloc #endif
--- a/src/oct-conf.h.in Mon Jan 02 15:19:45 2012 -0500 +++ b/src/oct-conf.h.in Fri Jan 06 12:43:48 2012 -0500 @@ -60,6 +60,18 @@ #define OCTAVE_CONF_AR %OCTAVE_CONF_AR% #endif +#ifndef OCTAVE_CONF_ARPACK_CPPFLAGS +#define OCTAVE_CONF_ARPACK_CPPFLAGS %OCTAVE_CONF_ARPACK_CPPFLAGS% +#endif + +#ifndef OCTAVE_CONF_ARPACK_LDFLAGS +#define OCTAVE_CONF_ARPACK_LDFLAGS %OCTAVE_CONF_ARPACK_LDFLAGS% +#endif + +#ifndef OCTAVE_CONF_ARPACK_LIBS +#define OCTAVE_CONF_ARPACK_LIBS %OCTAVE_CONF_ARPACK_LIBS% +#endif + #ifndef OCTAVE_CONF_BLAS_LIBS #define OCTAVE_CONF_BLAS_LIBS %OCTAVE_CONF_BLAS_LIBS% #endif
--- a/src/oct-parse.yy Mon Jan 02 15:19:45 2012 -0500 +++ b/src/oct-parse.yy Fri Jan 06 12:43:48 2012 -0500 @@ -3612,7 +3612,7 @@ { symbol_found = true; - FILE *fptr = fopen (file.c_str (), "r"); + FILE *fptr = gnulib::fopen (file.c_str (), "r"); if (fptr) {
--- a/src/octave.cc Mon Jan 02 15:19:45 2012 -0500 +++ b/src/octave.cc Fri Jan 06 12:43:48 2012 -0500 @@ -834,9 +834,10 @@ // If stdin is not a tty, then we are reading commands from a pipe or // a redirected file. - stdin_is_tty = isatty (fileno (stdin)); + stdin_is_tty = gnulib::isatty (fileno (stdin)); - interactive = (! embedded && stdin_is_tty && isatty (fileno (stdout))); + interactive = (! embedded && stdin_is_tty + && gnulib::isatty (fileno (stdout))); if (! interactive && ! forced_line_editing) line_editing = false;
--- a/src/ov-fcn-inline.cc Mon Jan 02 15:19:45 2012 -0500 +++ b/src/ov-fcn-inline.cc Fri Jan 06 12:43:48 2012 -0500 @@ -742,7 +742,7 @@ tmp_arg != "NaN" && tmp_arg != "nan" && tmp_arg != "Inf" && tmp_arg != "inf" && tmp_arg != "NA" && tmp_arg != "pi" && - tmp_arg != "eps") + tmp_arg != "e" && tmp_arg != "eps") fargs.append (tmp_arg); tmp_arg = std::string ();
--- a/src/sighandlers.cc Mon Jan 02 15:19:45 2012 -0500 +++ b/src/sighandlers.cc Fri Jan 06 12:43:48 2012 -0500 @@ -185,15 +185,8 @@ { octave_set_signal_handler (sig_number, SIG_DFL); -#if defined (HAVE_RAISE) - raise (sig_number); -#elif defined (HAVE_KILL) - kill (getpid (), sig_number); -#else - exit (1); -#endif + gnulib::raise (sig_number); } - } }
--- a/src/sysdep.cc Mon Jan 02 15:19:45 2012 -0500 +++ b/src/sysdep.cc Fri Jan 06 12:43:48 2012 -0500 @@ -288,7 +288,7 @@ static bool curr_on = false; int tty_fd = STDIN_FILENO; - if (! isatty (tty_fd)) + if (! gnulib::isatty (tty_fd)) { if (interactive) error ("stdin is not a tty!");
--- a/src/toplev.cc Mon Jan 02 15:19:45 2012 -0500 +++ b/src/toplev.cc Fri Jan 06 12:43:48 2012 -0500 @@ -1082,7 +1082,17 @@ OCTAVE_SAFE_CALL (flush_octave_stdout, ()); } - OCTAVE_SAFE_CALL (singleton_cleanup_list::cleanup, ()); + // Don't call singleton_cleanup_list::cleanup until we have the + // problems with registering/unregistering types worked out. For + // example, uncomment the following line, then use the make_int + // function from the examples directory to create an integer + // object and then exit Octave. Octave should crash with a + // segfault when cleaning up the typinfo singleton. We need some + // way to force new octave_value_X types that are created in + // .oct files to be unregistered when the .oct file shared library + // is unloaded. + // + // OCTAVE_SAFE_CALL (singleton_cleanup_list::cleanup, ()); OCTAVE_SAFE_CALL (octave_chunk_buffer::clear, ()); } @@ -1235,6 +1245,9 @@ { false, "AMD_LIBS", OCTAVE_CONF_AMD_LIBS }, { false, "AR", OCTAVE_CONF_AR }, { false, "ARFLAGS", OCTAVE_CONF_ARFLAGS }, + { false, "ARPACK_CPPFLAGS", OCTAVE_CONF_ARPACK_CPPFLAGS }, + { false, "ARPACK_LDFLAGS", OCTAVE_CONF_ARPACK_LDFLAGS }, + { false, "ARPACK_LIBS", OCTAVE_CONF_ARPACK_LIBS }, { false, "BLAS_LIBS", OCTAVE_CONF_BLAS_LIBS }, { false, "CARBON_LIBS", OCTAVE_CONF_CARBON_LIBS }, { false, "CAMD_CPPFLAGS", OCTAVE_CONF_CAMD_CPPFLAGS },
--- a/src/version.h.in Mon Jan 02 15:19:45 2012 -0500 +++ b/src/version.h.in Fri Jan 06 12:43:48 2012 -0500 @@ -87,8 +87,5 @@ #define OCTAVE_STARTUP_MESSAGE \ X_OCTAVE_NAME_VERSION_COPYRIGHT_COPYING_WARRANTY_AND_BUGS \ (" For details, type `warranty'.") "\n\n" \ - "For information about changes from previous versions, type `news'.\n\n\ -** WARNING ** Semantics for arithmetic operators were changed\n\ - in version 3.6.0 and now broadcast.\n\ - Type `doc broadcast' to get a description of the changes." + "For information about changes from previous versions, type `news'." #endif