changeset 12274:9f5d2ef078e8 release-3-4-x

import ARPACK sources to libcruft from Debian package libarpack2 2.1+parpack96.dfsg-3+b1
author John W. Eaton <jwe@octave.org>
date Fri, 28 Jan 2011 14:04:33 -0500
parents 83133b5bf392
children 35c55d1241c7
files libcruft/ChangeLog libcruft/Makefile.am libcruft/arpack/ARPACK-license-question.email libcruft/arpack/README libcruft/arpack/RiceBSD.txt 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/dnaupe.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/snaupe.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 99 files changed, 36198 insertions(+), 0 deletions(-) [+]
line wrap: on
line diff
--- a/libcruft/ChangeLog
+++ b/libcruft/ChangeLog
@@ -1,3 +1,8 @@
+2011-01-28  John W. Eaton  <jwe@octave.org>
+
+	* arpack: New directory.
+	* Makefile.am: Include arpack/module.mk.
+
 2011-01-26  John W. Eaton  <jwe@octave.org>
 
 	* mkf77def.in: Strip trailing whitespace.
--- a/libcruft/Makefile.am
+++ b/libcruft/Makefile.am
@@ -57,6 +57,7 @@
 EXTRA_DIST =
 
 include amos/module.mk
+include arpack/module.mk
 include blas-xtra/module.mk
 include daspk/module.mk
 include dasrt/module.mk
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/ARPACK-license-question.email
@@ -0,0 +1,102 @@
+X-Mozilla-Status: 0011
+X-Mozilla-Status2: 00000000
+Received: from zuk35exm65.ds.mot.com ([10.178.1.44]) by zuk35exm62.ds.mot.com with Microsoft SMTPSVC(6.0.3790.2709);
+	 Tue, 13 Feb 2007 19:53:15 +0000
+Received: from az33exr02.mot.com ([10.64.251.232]) by zuk35exm65.ds.mot.com with Microsoft SMTPSVC(6.0.3790.2709);
+	 Tue, 13 Feb 2007 19:53:14 +0000
+Received: from motgate3.mot.com (motgate3.mot.com [144.189.100.103])
+	by az33exr02.mot.com (8.13.1/8.13.0) with ESMTP id l1DJrDDS020683
+	for <David.Bateman@motorola.com>; Tue, 13 Feb 2007 13:53:13 -0600 (CST)
+Received: from mail128.messagelabs.com (mail128.messagelabs.com [216.82.250.131])
+	by motgate3.mot.com (8.12.11/Motorola) with SMTP id l1DJr8gl023906
+	for <David.Bateman@motorola.com>; Tue, 13 Feb 2007 12:53:11 -0700 (MST)
+X-VirusChecked: Checked
+X-Env-Sender: sorensen@rice.edu
+X-Msg-Ref: server-6.tower-128.messagelabs.com!1171396385!13383447!1
+X-StarScan-Version: 5.5.10.7.1; banners=-,-,-
+X-Originating-IP: [128.42.17.10]
+X-SpamReason: No, hits=0.0 required=7.0 tests=
+Received: (qmail 3872 invoked from network); 13 Feb 2007 19:53:05 -0000
+Received: from caam.rice.edu (HELO caam.rice.edu) (128.42.17.10)
+  by server-6.tower-128.messagelabs.com with SMTP; 13 Feb 2007 19:53:05 -0000
+Received: from localhost (localhost [127.0.0.1])
+	by caam.rice.edu (Postfix) with ESMTP id 64341153A7
+	for <David.Bateman@motorola.com>; Tue, 13 Feb 2007 13:53:04 -0600 (CST)
+Received: from caam.rice.edu ([127.0.0.1])
+ by localhost (caam.rice.edu [127.0.0.1]) (amavisd-new, port 10024) with LMTP
+ id 23777-01-16 for <David.Bateman@motorola.com>;
+ Tue, 13 Feb 2007 13:52:59 -0600 (CST)
+Received: from [128.42.21.177] (sorensenl400.caam.rice.edu [128.42.21.177])
+	by caam.rice.edu (Postfix) with ESMTP id 494E81539F
+	for <David.Bateman@motorola.com>; Tue, 13 Feb 2007 13:52:59 -0600 (CST)
+Message-ID: <45D2171B.8030109@rice.edu>
+Date: Tue, 13 Feb 2007 13:52:59 -0600
+From: Dan Sorensen<sorensen@rice.edu>
+User-Agent: Thunderbird 1.5.0.9 (Windows/20061207)
+MIME-Version: 1.0
+To: David Bateman<David.Bateman@motorola.com>
+Subject: Re: ARPACK License Question
+References: <457EE5B3.70402@ieee.org> <20070105114426.GI4860@neu.nirvana> <45B8CB2F.9030904@motorola.com>
+In-Reply-To: <45B8CB2F.9030904@motorola.com>
+Content-Type: text/plain; charset=ISO-8859-1; format=flowed
+Content-Transfer-Encoding: 7bit
+X-Virus-Scanned: by amavis-2.2.1 at caam.rice.edu
+Return-Path: sorensen@rice.edu
+X-OriginalArrivalTime: 13 Feb 2007 19:53:14.0831 (UTC) FILETIME=[994B7DF0:01C74FA8]
+
+Dear Mr. Bateman
+
+I apologize for not responding to this previously.
+
+The clarification we discussed is the following
+
+
+The clause in the license statement  that states
+
+>>Written notification is provided to the developers of intent to use this 
+>> software. Also, we ask that use of ARPACK is properly cited in any 
+>> resulting publications or software documentation.
+
+has the following intension in your case.
+
+We are asking for acknowledgment in FEDORA that ARPACK is
+the software that underlies what corresponds to the  "eigs" command.   
+There is no intention to pass on a requirement of notification of use
+from users of FEDORA.   
+
+This is the understanding we have with MATLAB for example.
+
+If the above note or a slight modification of it is not acceptable
+for the purposes of using ARPACK in FEDORA, I will have to refer
+you to the tech transfer department of Rice University as I explained
+during our phone conversation.
+
+Once again my apologies for the delay and I thank you for your
+interest in ARPACK.
+
+Best Regards
+Dan Sorensen
+
+
+
+ 
+
+
+
+David Bateman wrote:
+> Dear Professor Sorensen,
+>
+> Perhaps you have not yet seen the e-mail below, and so I draw it to your
+> attention. Can you please examine the request to modify the license of
+> ARPACK in this mail belong to allow its inclusion in FEDORA and other
+> similar open source linux distributions?
+>
+> As the author of the eigs function for Octave (www.octave.org) that uses
+> ARPACK for its functionality, I'd hate to see my work not included in
+> Octave due to this question not being resolved.
+>
+> Best Regards
+> David
+>
+>   
+
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/README
@@ -0,0 +1,120 @@
+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.
+
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/RiceBSD.txt
@@ -0,0 +1,43 @@
+Rice BSD Software License
+
+Permits source and binary redistribution of the software ARPACK and
+P_ARPACK for both non-commercial and commercial use.
+
+ Copyright (©) 2001, 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:
+
+o Redistributions of source code must retain the above copyright
+  notice, this list of conditions and the following disclaimer.
+
+o Redistributions in binary form must reproduce the above copyright
+  notice, this list of conditions and the following disclaimer in the
+  documentation and/or other materials provided with the distribution.
+
+o If you modify the source for these routines we ask that you change
+  the name of the routine and comment the changes made to the
+  original.
+
+o Written notification is provided to the developers of intent to use
+  this software.  Also, we ask that use of ARPACK is properly cited in
+  any resulting publications or software documentation.
+
+o Neither the name of Rice University (RICE) 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 RICE 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 RICE 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.
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/docs/README
@@ -0,0 +1,18 @@
+
+  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. 
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/docs/debug.doc
@@ -0,0 +1,339 @@
+ 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.
+
+
+
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/docs/ex-complex.doc
@@ -0,0 +1,152 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/docs/ex-nonsym.doc
@@ -0,0 +1,256 @@
+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
+
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/docs/ex-sym.doc
@@ -0,0 +1,234 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/docs/stat.doc
@@ -0,0 +1,80 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/module.mk
@@ -0,0 +1,101 @@
+EXTRA_DIST += \
+  arpack/ARPACK-license-question.email \
+  arpack/README \
+  arpack/RiceBSD.txt \
+  docs/debug.doc \
+  docs/ex-complex.doc \
+  docs/ex-nonsym.doc \
+  docs/ex-sym.doc \
+  docs/README \
+  docs/stat.doc \
+  arpack/src/module.mk \
+  arpack/src/debug.h \
+  arpack/src/stat.h \
+  arpack/src/version.h \
+  arpack/util/module.mk
+
+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/dnaupe.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/snaupe.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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/cgetv0.f
@@ -0,0 +1,414 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/cnaitr.f
@@ -0,0 +1,850 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/cnapps.f
@@ -0,0 +1,507 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/cnaup2.f
@@ -0,0 +1,801 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/cnaupd.f
@@ -0,0 +1,664 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/cneigh.f
@@ -0,0 +1,257 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/cneupd.f
@@ -0,0 +1,872 @@
+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
+      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),
+     &                   nconv        , conds        , sep         , 
+     &                   workev       , ncv          , ierr)
+c
+            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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/cngets.f
@@ -0,0 +1,178 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/csortc.f
@@ -0,0 +1,322 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/cstatn.f
@@ -0,0 +1,51 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/debug.h
@@ -0,0 +1,16 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/dgetv0.f
@@ -0,0 +1,419 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/dlaqrb.f
@@ -0,0 +1,521 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/dnaitr.f
@@ -0,0 +1,840 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/dnapps.f
@@ -0,0 +1,647 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/dnaup2.f
@@ -0,0 +1,835 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/dnaupd.f
@@ -0,0 +1,693 @@
+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
new file mode 100644
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/dnconv.f
@@ -0,0 +1,146 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/dneigh.f
@@ -0,0 +1,314 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/dneupd.f
@@ -0,0 +1,1063 @@
+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 
+      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), 
+     &                   nconv        , conds        ,
+     &                   sep          , workl(ihbds) , 
+     &                   ncv          , iwork        ,
+     &                   1            , ierr)
+c
+            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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/dngets.f
@@ -0,0 +1,231 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/dsaitr.f
@@ -0,0 +1,853 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/dsapps.f
@@ -0,0 +1,516 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/dsaup2.f
@@ -0,0 +1,850 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/dsaupd.f
@@ -0,0 +1,690 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/dsconv.f
@@ -0,0 +1,138 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/dseigt.f
@@ -0,0 +1,181 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/dsesrt.f
@@ -0,0 +1,217 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/dseupd.f
@@ -0,0 +1,857 @@
+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
+ 30      end if
+c
+         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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/dsgets.f
@@ -0,0 +1,219 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/dsortc.f
@@ -0,0 +1,344 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/dsortr.f
@@ -0,0 +1,218 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/dstatn.f
@@ -0,0 +1,61 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/dstats.f
@@ -0,0 +1,47 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/dstqrb.f
@@ -0,0 +1,594 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/sgetv0.f
@@ -0,0 +1,419 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/slaqrb.f
@@ -0,0 +1,521 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/snaitr.f
@@ -0,0 +1,840 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/snapps.f
@@ -0,0 +1,647 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/snaup2.f
@@ -0,0 +1,835 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/snaupd.f
@@ -0,0 +1,693 @@
+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
new file mode 100644
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/snconv.f
@@ -0,0 +1,146 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/sneigh.f
@@ -0,0 +1,314 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/sneupd.f
@@ -0,0 +1,1063 @@
+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 
+      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), 
+     &                   nconv        , conds        ,
+     &                   sep          , workl(ihbds) , 
+     &                   ncv          , iwork        ,
+     &                   1            , ierr)
+c
+            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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/sngets.f
@@ -0,0 +1,231 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/ssaitr.f
@@ -0,0 +1,853 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/ssapps.f
@@ -0,0 +1,516 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/ssaup2.f
@@ -0,0 +1,850 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/ssaupd.f
@@ -0,0 +1,690 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/ssconv.f
@@ -0,0 +1,138 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/sseigt.f
@@ -0,0 +1,181 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/ssesrt.f
@@ -0,0 +1,217 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/sseupd.f
@@ -0,0 +1,857 @@
+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
+ 30      end if
+c
+         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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/ssgets.f
@@ -0,0 +1,219 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/ssortc.f
@@ -0,0 +1,344 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/ssortr.f
@@ -0,0 +1,218 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/sstatn.f
@@ -0,0 +1,61 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/sstats.f
@@ -0,0 +1,47 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/sstqrb.f
@@ -0,0 +1,594 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/stat.h
@@ -0,0 +1,21 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/version.h
@@ -0,0 +1,30 @@
+/*
+
+ 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'
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/zgetv0.f
@@ -0,0 +1,414 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/znaitr.f
@@ -0,0 +1,850 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/znapps.f
@@ -0,0 +1,507 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/znaup2.f
@@ -0,0 +1,801 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/znaupd.f
@@ -0,0 +1,664 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/zneigh.f
@@ -0,0 +1,257 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/zneupd.f
@@ -0,0 +1,872 @@
+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
+      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),
+     &                   nconv        , conds        , sep         , 
+     &                   workev       , ncv          , ierr)
+c
+            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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/zngets.f
@@ -0,0 +1,178 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/zsortc.f
@@ -0,0 +1,322 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/src/zstatn.f
@@ -0,0 +1,51 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/util/cmout.f
@@ -0,0 +1,250 @@
+*
+*  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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/util/cvout.f
@@ -0,0 +1,240 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/util/dmout.f
@@ -0,0 +1,167 @@
+*-----------------------------------------------------------------------
+*  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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/util/dvout.f
@@ -0,0 +1,122 @@
+*-----------------------------------------------------------------------
+*  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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/util/icnteq.f
@@ -0,0 +1,18 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/util/icopy.f
@@ -0,0 +1,77 @@
+*--------------------------------------------------------------------
+*\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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/util/iset.f
@@ -0,0 +1,16 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/util/iswap.f
@@ -0,0 +1,55 @@
+      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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/util/ivout.f
@@ -0,0 +1,120 @@
+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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/util/second.f
@@ -0,0 +1,36 @@
+      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
+      EXTERNAL           ETIME
+*     ..
+*     .. Executable Statements ..
+*
+
+      T1 = ETIME( TARRAY )
+      T  = TARRAY( 1 )
+
+      RETURN
+*
+*     End of ARSCND
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/util/smout.f
@@ -0,0 +1,157 @@
+*-----------------------------------------------------------------------
+*  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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/util/svout.f
@@ -0,0 +1,112 @@
+*-----------------------------------------------------------------------
+*  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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/util/zmout.f
@@ -0,0 +1,250 @@
+*
+*  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
new file mode 100644
--- /dev/null
+++ b/libcruft/arpack/util/zvout.f
@@ -0,0 +1,240 @@
+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