Mercurial > hg > octave-nkf
changeset 12194:470857149e61
import ARPACK sources to libcruft from Debian package libarpack2 2.1+parpack96.dfsg-3+b1
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 --- /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 --- /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