#! /bin/sh # This is a shell archive. Remove anything before this line, then unpack # it by saving it into a file and typing "sh file". To overwrite existing # files, type "sh file -c". You can also feed this as standard input via # unshar, or by typing "sh 'README' <<'END_OF_FILE' X *************************************************************************** X * All the software contained in this library is protected by copyright. * X * Permission to use, copy, modify, and distribute this software for any * X * purpose without fee is hereby granted, provided that this entire notice * X * is included in all copies of any software which is or includes a copy * X * or modification of this software and in all copies of the supporting * X * documentation for such software. * X *************************************************************************** X * THIS SOFTWARE IS BEING PROVIDED "AS IS", WITHOUT ANY EXPRESS OR IMPLIED * X * WARRANTY. IN NO EVENT, NEITHER THE AUTHORS, NOR THE PUBLISHER, NOR ANY * X * MEMBER OF THE EDITORIAL BOARD OF THE JOURNAL "NUMERICAL ALGORITHMS", * X * NOR ITS EDITOR-IN-CHIEF, BE LIABLE FOR ANY ERROR IN THE SOFTWARE, ANY * X * MISUSE OF IT OR ANY DAMAGE ARISING OUT OF ITS USE. THE ENTIRE RISK OF * X * USING THE SOFTWARE LIES WITH THE PARTY DOING SO. * X *************************************************************************** X * ANY USE OF THE SOFTWARE CONSTITUTES ACCEPTANCE OF THE TERMS OF THE * X * ABOVE STATEMENT. * X *************************************************************************** X X AUTHORS: X X M. Sadkane X Universite de Bretagne Occidentale, Brest, France X E-MAIL: sadkane@univ-brest.fr X X R. B. Sidje X University of Queensland, Brisbane, Australia X E-MAIL: rbs@maths.uq.edu.au X X REFERENCE: X X - Implementation of a Variable Block Davidson Method with Deflation X for Solving Large Sparse Eigenproblems X NUMERICAL ALGORITHMS, 20 (1999), PP. 217-240 X X SOFTWARE REVISION DATE: X X JANUARY 11, 1999 X X SOFTWARE LANGUAGE: X X FORTRAN 77 X X--------------------------------------------------------------------------- XThis is a Fortran-77 software package which implements a deflated and Xvariable-block version of the Davidson method for computing a few of Xthe extreme (i.e., leftmost or rightmost) eigenpairs of large sparse Xsymmetric matrices. X X C O N T E N T S X=========================================================================== XThis README is divided into three main parts: XPART 1. QUICK SUMMARY - Quick overview of the package XPART 2. SAMPLES OF SESSION - Outputs obtained by executing the software XPART 3. DETAILED GUIDE - Further details about the package X X=========================================================================== X P A R T 1. X Q U I C K S U M M A R Y X=========================================================================== XBelow is an overview of the different components of the package. XWithin each module given below, there is a detailed header which lists Xthe elements contained in the module and their purpose. For each Xroutine in the module, the header includes a section which gives the aim Xof the routine, the routines that are called ("Called Routines"), as Xwell as the other routines of the package in which the routine itself Xis called ("Calling Routines"). X XA/ DATA X--------------------------------------------------------------------------- Xgr3030 : Harwell-Boeing matrix X Xinit.data.example for the driver runme: X This is an example of how to set input data for the driver runme. X In order to be used, copy init.data.example to init.data X or simply type the command "runme init.data.example" X XB/ DRIVERS X--------------------------------------------------------------------------- Xrunme.f : driver using external data. X Xalone.f : simple self-contained stand-alone driver. X XMakefile : makefile allowing to build the executables. X To build the stand-alone driver simply type "make alone" X To build the advanced driver simply type "make runme" X XC/ MODULES TO HANDLE THE INPUT/OUTPUT PHASES X--------------------------------------------------------------------------- Xcommon.inc: common/global variables. X Users can modify the file to add their own extra variables X Xio.f : input/output management X Xrandm.f : generates a matrix of random numbers using the function DLARN X from the LAPACK testing suite (DLARN is included in the package) X Xgetmat.f : gets the matrix, make up the corrector, get initial guesses. X Users can modify the module to add their own matrix loading X routines X Xeigsrt.f : sorts the eigenpairs with respect to eigenvalues or residuals. X XD/ COMPUTATIONAL MODULES X--------------------------------------------------------------------------- Xdavpack.f : Davidson's algorithm. X Xmatvec.f : block matrix-vector multiplication routines. X Users can modify the module to add their own matrix-vector X routines X Xexpokit.f : relevant subset extracted from the matrix exponential package X EXPOKIT. X Xichol.f : LDL^T variant of Incomplete Choleski. X Xcorrec.f : routines to perform the correction/preconditioning step in X Davidson's algorithm. X Users can modify the module to add their own preconditioners X XE/ BLAS/LAPACK X--------------------------------------------------------------------------- Xblas.f and lapack.f : X These files assemble the relevant subsets of BLAS and LAPACK X needed by the package. By uncommenting or commenting the X appropriate lines in the Makefile, one may link either to these X substitutes or the local installations of BLAS and/or LAPACK. X X=========================================================================== X P A R T 2. X S A M P L E S O F S E S S I O N X (On a SUN workstation with Solaris) X XSample 1: alone (using g77 -O3) XSample 2: runme (using g77 -O3) XSample 3: alone (using f77 -O3) XSample 4: runme (using f77 -O3) XSample 5: runme init.data.example (using f77 -O3) X=========================================================================== X X WARNING: on a SUN system, at the end of the output, the following X note may appear (without affecting the correctness of the results): X XNote: the following IEEE floating-point arithmetic exceptions Xoccurred and were never cleared; see ieee_flags(3M): XInexact; Underflow; XSun's implementation of IEEE arithmetic is discussed in Xthe Numerical Computation Guide. X X########################################################################### XSample 1: alone (using g77 -O3) X########################################################################### X X%alone X Generating the matrix ... X machine epsilon = 2.22044605E-16 X tolerance used = 1.E-10 X Xiter basis nmult block nevf residual X 2 2 2 0 6.274E+00 X 4 4 2 0 4.829E+00 X 6 6 2 0 4.621E+00 X 8 8 2 0 3.197E+00 X 10 10 2 0 2.988E+00 X 12 12 2 0 2.527E+00 X 14 14 2 0 2.117E+00 X 16 16 2 0 2.024E+00 X 18 18 2 0 2.084E+00 X 1 20 20 2 0 1.804E+00 X-------------------------------------------- X 4 24 4 0 2.177E+00 X 6 26 2 0 2.217E+00 X 8 28 2 0 1.751E+00 X 10 30 2 0 2.323E+00 X 12 32 2 0 2.080E+00 X 14 34 2 0 2.446E+00 X 16 36 2 0 2.218E+00 X 18 38 2 0 2.510E+00 X 2 20 40 2 0 2.524E+00 X-------------------------------------------- X 4 44 4 0 2.331E+00 X 6 46 2 0 2.124E+00 X 8 48 2 0 2.077E+00 X 10 50 2 0 1.965E+00 X 12 52 2 0 1.838E+00 X 14 54 2 0 1.638E+00 X 16 56 2 0 1.701E+00 X 18 58 2 0 1.665E+00 X 3 20 60 2 0 1.597E+00 X-------------------------------------------- X 4 64 4 0 1.572E+00 X 6 66 2 0 2.062E+00 X 8 68 2 0 1.826E+00 X 10 70 2 0 1.888E+00 X 12 72 2 0 1.452E+00 X 14 74 2 0 7.878E-01 X 16 76 2 0 6.184E-01 X 18 78 2 0 7.799E-01 X 4 20 80 2 0 4.594E-01 X-------------------------------------------- X 4 84 4 0 2.438E-01 X 6 86 2 0 2.128E-01 X 8 88 2 0 1.910E-01 X 10 90 2 0 1.951E-01 X 12 92 2 0 1.490E-01 X 14 94 2 0 9.609E-02 X 16 96 2 0 5.960E-02 X 18 98 2 0 4.364E-02 X 5 20 100 2 0 2.286E-02 X-------------------------------------------- X 4 104 4 0 1.133E-02 X 6 106 2 0 9.091E-03 X 8 108 2 0 4.869E-03 X 10 110 2 0 2.875E-03 X 12 112 2 0 1.720E-03 X 14 114 2 0 1.026E-03 X 16 116 2 0 8.118E-04 X 18 118 2 0 4.948E-04 X 6 20 120 2 0 4.553E-04 X-------------------------------------------- X 4 124 4 0 2.651E-04 X 6 126 2 0 3.858E-04 X 8 128 2 0 3.391E-04 X 10 130 2 0 3.397E-04 X 12 132 2 0 3.114E-04 X 14 134 2 0 2.538E-04 X 16 136 2 0 1.837E-04 X 18 138 2 0 1.177E-04 X 7 20 140 2 0 7.538E-05 X-------------------------------------------- X 4 144 4 0 3.999E-05 X 6 146 2 0 2.841E-05 X 8 148 2 0 1.755E-05 X 10 150 2 0 1.121E-05 X 12 152 2 0 8.045E-06 X 14 154 2 0 5.543E-06 X 16 156 2 0 4.396E-06 X 18 158 2 0 2.656E-06 X 8 20 160 2 0 2.499E-06 X-------------------------------------------- X 4 164 4 0 1.624E-06 X 6 166 2 0 2.651E-06 X 8 168 2 0 2.274E-06 X 10 170 2 0 2.492E-06 X 12 172 2 0 2.036E-06 X 14 174 2 0 1.783E-06 X 16 176 2 0 1.046E-06 X 18 178 2 0 7.020E-07 X 9 20 180 2 0 4.875E-07 X-------------------------------------------- X 4 184 4 0 2.380E-07 X 6 186 2 0 1.762E-07 X 8 188 2 0 1.142E-07 X 10 190 2 0 6.470E-08 X 12 192 2 0 4.387E-08 X 14 194 2 0 2.744E-08 X 16 196 2 0 2.314E-08 X 18 198 2 0 1.353E-08 X 10 20 200 2 0 1.482E-08 X-------------------------------------------- X 4 204 4 0 8.702E-09 X 6 206 2 0 1.543E-08 X 8 208 2 0 1.307E-08 X 10 210 2 0 1.431E-08 X 12 212 2 0 1.306E-08 X 14 214 2 0 9.364E-09 X 11 16 216 2 1 7.155E-11 X-------------------------------------------- X X Runtime (seconds) = 0.031249546 X Mat-vec products = 216 X Residual = 7.15459411E-11 X Eigenvalue = 11.1321623 X X########################################################################### XSample 2: runme (using g77 -O3) X########################################################################### X X%runme XNo `init.data' file. Default internal configuration is used. XHBO matrix filename? Xgr3030 X 1SYMMETRIC MATRIX FROM NINE POINT START ON A 30 X 30 GRID. type : X RSA size : 900 900 X order : 900 number of nonzero : 4322 X ||A||_inf = 12. XInput phase OK... X---------------------------------------- X machine epsilon = 2.22044605E-16 X tolerance used = 1.00000001E-07 X Xiter basis nmult block nevf residual X 1 40 40 1 0 2.277E-03 X 2 40 80 1 0 3.012E-05 X 3 40 120 1 0 2.183E-07 X 4 15 135 1 1 9.515E-08 X XRuntime (seconds): 7.188E-03 XTotal number of iterations used: 4 XTotal number of matrix * vector: 135 X------------- INFORMATION -------------- X matfile: gr3030 X mattype: hbo Xguessfile: X errfile: X outfile: X outfmt: 1P,E22.15 Xinfolevel: 1 X basis: 40 X block: 1 Xeigenpair: 1 Xiteration: 100 Xcorrector: 1 X outmax: 5 Xtolerance: 1.00E-07 X---------------------------------------- X XRESIDUALS = X 9.514969539817650E-08 X XEIGENVALUES = X 1.195905988250289E+01 X XEIGENVECTORS = X 4.847095996510790E-04 X 1.588202453176127E-03 X 1.434279286987249E-03 X 3.111376095734475E-03 X 2.325096331228699E-03 X X X########################################################################### XSample 3: alone (using f77 -O3) X########################################################################### X X%alone X Generating the matrix ... X machine epsilon = 2.2204460492503D-16 X tolerance used = 1.0000000000000D-10 X Xiter basis nmult block nevf residual X 2 2 2 0 6.274E+00 X 4 4 2 0 4.829E+00 X 6 6 2 0 4.621E+00 X 8 8 2 0 3.197E+00 X 10 10 2 0 2.988E+00 X 12 12 2 0 2.527E+00 X 14 14 2 0 2.117E+00 X 16 16 2 0 2.024E+00 X 18 18 2 0 2.084E+00 X 1 20 20 2 0 1.804E+00 X-------------------------------------------- X 4 24 4 0 2.177E+00 X 6 26 2 0 2.217E+00 X 8 28 2 0 1.751E+00 X 10 30 2 0 2.323E+00 X 12 32 2 0 2.080E+00 X 14 34 2 0 2.446E+00 X 16 36 2 0 2.218E+00 X 18 38 2 0 2.510E+00 X 2 20 40 2 0 2.524E+00 X-------------------------------------------- X 4 44 4 0 2.331E+00 X 6 46 2 0 2.124E+00 X 8 48 2 0 2.077E+00 X 10 50 2 0 1.965E+00 X 12 52 2 0 1.838E+00 X 14 54 2 0 1.638E+00 X 16 56 2 0 1.701E+00 X 18 58 2 0 1.665E+00 X 3 20 60 2 0 1.597E+00 X-------------------------------------------- X 4 64 4 0 1.572E+00 X 6 66 2 0 2.062E+00 X 8 68 2 0 1.826E+00 X 10 70 2 0 1.888E+00 X 12 72 2 0 1.452E+00 X 14 74 2 0 7.878E-01 X 16 76 2 0 6.184E-01 X 18 78 2 0 7.799E-01 X 4 20 80 2 0 4.594E-01 X-------------------------------------------- X 4 84 4 0 2.438E-01 X 6 86 2 0 2.128E-01 X 8 88 2 0 1.910E-01 X 10 90 2 0 1.951E-01 X 12 92 2 0 1.490E-01 X 14 94 2 0 9.609E-02 X 16 96 2 0 5.960E-02 X 18 98 2 0 4.364E-02 X 5 20 100 2 0 2.286E-02 X-------------------------------------------- X 4 104 4 0 1.133E-02 X 6 106 2 0 9.091E-03 X 8 108 2 0 4.869E-03 X 10 110 2 0 2.875E-03 X 12 112 2 0 1.720E-03 X 14 114 2 0 1.026E-03 X 16 116 2 0 8.118E-04 X 18 118 2 0 4.948E-04 X 6 20 120 2 0 4.553E-04 X-------------------------------------------- X 4 124 4 0 2.651E-04 X 6 126 2 0 3.858E-04 X 8 128 2 0 3.391E-04 X 10 130 2 0 3.397E-04 X 12 132 2 0 3.114E-04 X 14 134 2 0 2.538E-04 X 16 136 2 0 1.837E-04 X 18 138 2 0 1.177E-04 X 7 20 140 2 0 7.538E-05 X-------------------------------------------- X 4 144 4 0 3.999E-05 X 6 146 2 0 2.841E-05 X 8 148 2 0 1.755E-05 X 10 150 2 0 1.121E-05 X 12 152 2 0 8.045E-06 X 14 154 2 0 5.543E-06 X 16 156 2 0 4.396E-06 X 18 158 2 0 2.656E-06 X 8 20 160 2 0 2.499E-06 X-------------------------------------------- X 4 164 4 0 1.624E-06 X 6 166 2 0 2.651E-06 X 8 168 2 0 2.274E-06 X 10 170 2 0 2.492E-06 X 12 172 2 0 2.036E-06 X 14 174 2 0 1.783E-06 X 16 176 2 0 1.046E-06 X 18 178 2 0 7.020E-07 X 9 20 180 2 0 4.875E-07 X-------------------------------------------- X 4 184 4 0 2.380E-07 X 6 186 2 0 1.762E-07 X 8 188 2 0 1.142E-07 X 10 190 2 0 6.470E-08 X 12 192 2 0 4.387E-08 X 14 194 2 0 2.744E-08 X 16 196 2 0 2.314E-08 X 18 198 2 0 1.353E-08 X 10 20 200 2 0 1.482E-08 X-------------------------------------------- X 4 204 4 0 8.702E-09 X 6 206 2 0 1.543E-08 X 8 208 2 0 1.307E-08 X 10 210 2 0 1.431E-08 X 12 212 2 0 1.306E-08 X 14 214 2 0 9.364E-09 X 11 16 216 2 1 7.155E-11 X-------------------------------------------- X X Runtime (seconds) = 1.5833926200867 X Mat-vec products = 216 X Residual = 7.1545941069204D-11 X Eigenvalue = 11.132162270033 X X########################################################################### XSample 4: runme (using f77 -O3) X########################################################################### X X%runme XNo `init.data' file. Default internal configuration is used. XHBO matrix filename? Xgr3030 X 1SYMMETRIC MATRIX FROM NINE POINT START ON A 30 X 30 GRID. type : X RSA size : 900 900 X order : 900 number of nonzero : 4322 X ||A||_inf = 12.000000000000 XInput phase OK... X---------------------------------------- X machine epsilon = 2.2204460492503D-16 X tolerance used = 1.0000000000000D-07 X Xiter basis nmult block nevf residual X 1 40 40 1 0 2.277E-03 X 2 40 80 1 0 3.012E-05 X 3 40 120 1 0 2.183E-07 X 4 15 135 1 1 9.515E-08 X XRuntime (seconds): 1.401E+00 XTotal number of iterations used: 4 XTotal number of matrix * vector: 135 X------------- INFORMATION -------------- X matfile: gr3030 X mattype: hbo Xguessfile: X errfile: X outfile: X outfmt: 1P,E22.15 Xinfolevel: 1 X basis: 40 X block: 1 Xeigenpair: 1 Xiteration: 100 Xcorrector: 1 X outmax: 5 Xtolerance: 1.00E-07 X---------------------------------------- X XRESIDUALS = X 9.514969539817650E-08 X XEIGENVALUES = X 1.195905988250289E+01 X XEIGENVECTORS = X 4.847095996510790E-04 X 1.588202453176127E-03 X 1.434279286987249E-03 X 3.111376095734475E-03 X 2.325096331228699E-03 X X########################################################################### XSample 5: runme init.data.example (using f77 -O3) X########################################################################### X X% runme init.data.example Xinit.data.example>infolevel= 1 Xinit.data.example> matfile= gr3030 Xinit.data.example> outfmt= 1P,E11.3 X 1SYMMETRIC MATRIX FROM NINE POINT START ON A 30 X 30 GRID. type : X RSA size : 900 900 X order : 900 number of nonzero : 4322 X ||A||_inf = 12.000000000000 XInput phase OK... X---------------------------------------- X machine epsilon = 2.2204460492503D-16 X tolerance used = 1.0000000000000D-07 X Xiter basis nmult block nevf residual X 1 40 40 1 0 2.277E-03 X 2 40 80 1 0 3.012E-05 X 3 40 120 1 0 2.183E-07 X 4 15 135 1 1 9.515E-08 X XRuntime (seconds): 1.403E+00 XTotal number of iterations used: 4 XTotal number of matrix * vector: 135 X------------- INFORMATION -------------- X matfile: gr3030 X mattype: hbo Xguessfile: X errfile: X outfile: X outfmt: 1P,E11.3 Xinfolevel: 1 X basis: 40 X block: 1 Xeigenpair: 1 Xiteration: 100 Xcorrector: 1 X outmax: 5 Xtolerance: 1.00E-07 X---------------------------------------- X XRESIDUALS = X 9.515E-08 X XEIGENVALUES = X 1.196E+01 X XEIGENVECTORS = X 4.847E-04 X 1.588E-03 X 1.434E-03 X 3.111E-03 X 2.325E-03 X X=========================================================================== X X P A R T 3. X D E T A I L E D G U I D E X=========================================================================== X XThe Davidson method is a preconditioned eigenvalue technique aimed at Xcomputing a few of the extreme (i.e., leftmost or rightmost) Xeigenpairs of large sparse symmetric matrices. The method has gained Xquite an interest in quantum chemistry where it emanated. However, for Xthe classical Davidson method to be suitable, the matrix dealt with Xmust be strongly diagonally dominant (in the sense that its Xeigenvectors are close to the canonical vectors). The algorithm then Xuses the diagonal as preconditioner. Further recent investigations Xhave shown that the method can be used with more general Xpreconditioners and therefore can be applied successfully to matrices Xarising in other fields. The crux of the problem now resides in Xchosing an appropriate preconditioner for the situation at hand. X XThis package is a generalized block implementation of the Davidson Xmethod. The block implementation increases memory performance through Xdata locality and cache reuse. More specifically, this implementation Xis a variable block implementation in the sense that the block-size is Xadjusted (downward or upward) on the fly. Several eigenpairs are Xcomputed at once and the eigenpairs that converge are deflated. The Xpreconditioning stage is implemented with a variety of general Xpreconditioners instead of using only the diagonal as it was proposed Xoriginally. Built-in preconditioners are: diagonal, tridiagonal, Xpentadiagonal, Gauss-Seidel, Incomplete Choleski, Exponential. X XAdditionally, the package contains interface routines for input/output Xmanagement and this allows an end-user to exploit the software Xdirectly in a stand-alone fashion without extra coding. Besides, the Xmodular organization of the package enables interested users to either Xextract the core computational routines in view of utilizing them Xelsewhere, or add in the present package their own routines for Xhandling matrix-dependent operations. These include: matrix loading, Xmatrix multiplication, preconditioning. X XThe present package is ready-to-use for matrices stored under the XHarwell-Boeing storage format (HBO), Compressed Column Storage format X(CCS) and the Coordinates storage format (COO). X XThe implementation has been successfully tested on SUN and SGI Xplatforms. X XINSTALLATION X------------ X XThe package is written in Fortran 77 and uses external routines from Xthe well-known dense linear algebra libraries BLAS and LAPACK. If you Xdo not have BLAS and/or LAPACK, the files blas.f and lapack.f within Xthis package provide the relevant subsets of BLAS and LAPACK needed. XThe Makefile has further details on how to use either these substitutes Xor your own local installations of BLAS and/or LAPACK. X XTyping "make alone" builds a simple self-contained stand-alone driver. X XTyping "make runme" builds a more elaborated driver that uses Xexternal data. X XOnce the executables have been successfully built, they can be run Xdirectly. They will use default settings. X XIf the compilation is unsuccessful, one may need to edit the Makefile Xin order to change either the compiler name or the libraries with Xrespect to the local installations. X XEXECUTION X--------- X XThe use of the driver "alone" is straightforward. Simply type the Xcommand "alone". (Its source code integrates its own initializations). XThe remainder of this document is concerned only with the driver "runme". X Xsyntax: runme [name-of-initialization-file] X XIf no initialization file is specified on the command line (i.e., Xthe command is just "runme"), the code will consider init.data as the Xdefault initialization file. If the file init.data does not exist, the Xcode will use default initialization values (see below) and will prompt Xthe user for the name of a file containing a Harwell-Boeing matrix. X XWhen the matrix is loaded, the data needed for the corrector (or Xpreconditioner) are retrieved or computed from the matrix. If the Xuser has specified an initial guess file, initial guess vectors are Xread from the user's file, otherwise, they are generated randomly. XMatrix and corrector data sets are passed through common blocks that Xare declared in the file common.inc. X XMANAGING INPUT/OUTPUT X--------------------- X XThe driver runme uses a number of parameters that can be tuned by the Xuser. All these parameters and their default values are summarized here X(More details are given in the file init.data.example which can be used Xdirectly with the command "runme init.data.example"). X XName Description X----------------------------------------------------------------------- Xmatfile : string - the name of the file containing the matrix X (default = screen) Example: gr3030 X Xmattype : string of 3 characters - the format in which the matrix X is stored (hbo or coo or ccs) X (default = hbo) Example: coo X Xguessfile : string - the name of a file containing initial guesses, for X eigenvectors X (default = unspecified) Example: guess_file X if unspecified, guesses are generated internally (random) X if specified, guesses are read from the file X Xerrfile : string - the name of a file in which error messages should be X reported X (default = screen) Example: error_file X Xoutfile : string - the name of a file in which to put results of the X computation X (default = screen) Example: output_file X Xoutfmt : string - format for output results as per the Fortran 77 syntax X (default = 1P,E22.15) Example: 1P,E11.3 X Xinfolevel : integer between 0 and 5 - information level gauge X (default = 1) Example: 2 X Xbasis : integer - the maximum basis size X (default = 40) Example: 30 X Xblock : integer - the initial block size X (default = 1) Example: 4 X Xeigenpair : integer - number of desired leftmost/rightmost eigenpairs X -p searches for the p leftmost eigenpairs X (default = 1) Example: -3 X Xiteration : integer - maximum allowable number of iterations (i.e., restarts) X (default = 100) Example: 50 X Xcorrector : integer - the numeric identifier of the corrector/preconditioner X (default = 1) Example: -1 X 0 = no internal correction (NC) X 1 = diagonal correction (DC) X 2 = tridiagonal correction (TC) X 3 = pentadiagonal correction (PC) X -1 = Gauss-Seidel correction (GS) X -2 = Incomplete Choleski correction (IC) X -3 = Exponential correction (EX) X Xoutmax : integer - number of rows written on output X -k causes the last k rows to be written X (default = 5) Example: -7 X Xtolerance : double precision - required tolerance on the residuals X (default = 1.0E-7) Example: 1.0E-5 X XEXIT CODES X---------- X XWhen the computation aborts, either of the following exit codes Xmay be reported: X *A negative value means bad input arguments: X ifail = -1 if the basis-size exceeds the order of the X problem X X ifail = -2 if the basis-size exceeds the order or the X block-size exceeds the basis-size X X ifail = -3 if the order exceeds the declared X leading dimension X X ifail = -4 if the integer workspace is insufficient X X ifail = -5 if the workspace is insufficient X X Note that if inputs are not initialized properly (e.g. X if the order is 0), one or another error may be reported. X X *A positive value means a runtime failure occurred. X Current exit codes are: X ifail = 8 if a failure occurred in LAPACK when solving X the Ritz problem. X ifail = 9 if the maximum allowable number of iterations X was reached without convergence of all of the X eigenpairs. X XMODIFICATION OF THE PACKAGE X--------------------------- X XEXTRACTING THE CORE COMPUTATIONAL ROUTINES X------------------------------------------ X XIf you wish to extract the core computational routines of this package Xin view of their utilization from within another existing package, then Xalone.f provides the necessary illustration as to how this can be done. X XThe core computational routines are grouped in the file davpack.f. XThis file is computationally self-contained and does not use common Xvariables. The routines there are matrix-free, i.e., they are Xindependent of the matrix data storage format. Utilization of these Xroutines is possible outside of the actual package provided the Xfollowing (see alone.f): X- a matrix-vector multiplication routine (matvec) X- a correction routine (correc) X- link either with your local installations of BLAS and LAPACK or X the subsets blas.f and lapack.f provided in this package. X XUSER-DEFINED MATRIX FORMAT X-------------------------- X XIf you want to operate with matrices stored in a format not currently Xsupported in the package, you can either pre-process the matrices and Xconvert them into a supported format, or your can add the routines that Xwill support your format within the package: X X- Modify getmat.f to load your matrix (see explanations in getmat.f) X- Modify matvec.f to add your block matrix-vector product (see X explanations in matvec.f) X XThe same considerations apply if the matrix is not available explicitly. XThe user can modify getmat.f to add some upfront initializations, and Xthen modify matvec.f to insert the matrix-vector function. X XUSER-DEFINED CORRECTOR (PRECONDITIONER) X--------------------------------------- X XThis section describes how to add your own corrector. This operation has Xtwo aspects: i) initialization of your corrector, and ii) application of Xthe corrector at each correction stage. X Xi) Initialization: If the data for your corrector can be retrieved Xupfront when the matrix is loaded, then modify getmat.f to initialize Xyour corrector at the same time that the matrix is initialized. The Xdiagonal, tridiagonal, pentadiognal correctors of this package are Xconstructed in that way. Some correctors do not need an upfront Xinitialization. The Choleski corrector, for example, is recomputed at Xeach correction stage. X Xii) Application: Modify correc.f to add your corrector routine Xthat will be called at each correction stage (see explanations in Xcorrec.f). X XUSER-DEFINED VARIABLES X---------------------- X XAll the variables that need to be shared across modules are grouped Xin the file common.inc. This file is included (with the the Fortran 77 Xstatement "include 'common.inc'") in all the modules except davpack.f. X XIn the course of implementing your matrix loading routines, corrector, Xor matrix-vector multiplication routines, you can re-use variables Xfrom the common file, augment the declared sizes of the variables, Xor add your own extra variables. X XThe file common.inc includes the following variables: X XSizes: X------ X integer c_nmax, c_nzmax, c_n, c_nz X parameter( c_nmax=15500, c_nzmax=550000 ) X X The settings are large enough for all the matrices in the X Harwell-Boeing collection as of March 28, 1994, X except bcsstk30, 31, and 32 in bcsstuc5.data. X XMatrix data: X------------ X double precision c_a(c_nzmax), c_anorm X integer c_ia(c_nzmax), c_ja(c_nzmax) X common /MATRIX/ X. c_anorm,- some norm of the matrix X. c_a, - non-zeros values of the matrix X. c_ia, - depending on format: row indices or row pointers X. c_ja, - depending on format: column indices or column pointers X. c_nz, - number of non-zeros X. c_n - order of the matrix X XCorrector data: X--------------- X double precision c_diag(c_nmax,3) X X The array holds the appropriate number of diagonals of the matrix X to enable Diagonal, Tridiagonal, Pentadiagonal correctors X X double precision c_ac(c_nzmax) X integer c_ic(c_nzmax), c_jc(c_nmax+1) X common /CORRECTOR/ X. c_diag, c_ac, c_ic, c_jc X X These arrays are used to hold the factors of the Incomplete X Choleski (LDL^T variant) corrector. X XNOTE: X----- XIt is important to keep in mind that there is only one "active" Xpreconditioner and matrix-vector module per run. Hence each Xpreconditioner can use the common arrays as workspace. X XConsequently, while designing their preconditioner or matrix-vector Xmultiplication routines, users can use and modify the arrays Xin common.inc accordingly. X END_OF_FILE if test 34246 -ne `wc -c <'README'`; then echo shar: \"'README'\" unpacked with wrong size! fi # end of 'README' fi if test -f 'gr3030' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'gr3030'\" else echo shar: Extracting \"'gr3030'\" \(56700 characters\) sed "s/^X//" >'gr3030' <<'END_OF_FILE' X1SYMMETRIC MATRIX FROM NINE POINT START ON A 30 X 30 GRID. GR 30 30 X 696 46 217 433 0 XRSA 900 900 4322 0 X(20I4) (20I4) (10F8.1) X 1 5 10 15 20 25 30 35 40 45 50 55 60 65 70 75 80 85 90 95 X 100 105 110 115 120 125 130 135 140 145 148 152 157 162 167 172 177 182 187 192 X 197 202 207 212 217 222 227 232 237 242 247 252 257 262 267 272 277 282 287 292 X 295 299 304 309 314 319 324 329 334 339 344 349 354 359 364 369 374 379 384 389 X 394 399 404 409 414 419 424 429 434 439 442 446 451 456 461 466 471 476 481 486 X 491 496 501 506 511 516 521 526 531 536 541 546 551 556 561 566 571 576 581 586 X 589 593 598 603 608 613 618 623 628 633 638 643 648 653 658 663 668 673 678 683 X 688 693 698 703 708 713 718 723 728 733 736 740 745 750 755 760 765 770 775 780 X 785 790 795 800 805 810 815 820 825 830 835 840 845 850 855 860 865 870 875 880 X 883 887 892 897 902 907 912 917 922 927 932 937 942 947 952 957 962 967 972 977 X 982 987 992 9971002100710121017102210271030103410391044104910541059106410691074 X10791084108910941099110411091114111911241129113411391144114911541159116411691174 X11771181118611911196120112061211121612211226123112361241124612511256126112661271 X12761281128612911296130113061311131613211324132813331338134313481353135813631368 X13731378138313881393139814031408141314181423142814331438144314481453145814631468 X14711475148014851490149515001505151015151520152515301535154015451550155515601565 X15701575158015851590159516001605161016151618162216271632163716421647165216571662 X16671672167716821687169216971702170717121717172217271732173717421747175217571762 X17651769177417791784178917941799180418091814181918241829183418391844184918541859 X18641869187418791884188918941899190419091912191619211926193119361941194619511956 X19611966197119761981198619911996200120062011201620212026203120362041204620512056 X20592063206820732078208320882093209821032108211321182123212821332138214321482153 X21582163216821732178218321882193219822032206221022152220222522302235224022452250 X22552260226522702275228022852290229523002305231023152320232523302335234023452350 X23532357236223672372237723822387239223972402240724122417242224272432243724422447 X24522457246224672472247724822487249224972500250425092514251925242529253425392544 X25492554255925642569257425792584258925942599260426092614261926242629263426392644 X26472651265626612666267126762681268626912696270127062711271627212726273127362741 X27462751275627612766277127762781278627912794279828032808281328182823282828332838 X28432848285328582863286828732878288328882893289829032908291329182923292829332938 X29412945295029552960296529702975298029852990299530003005301030153020302530303035 X30403045305030553060306530703075308030853088309230973102310731123117312231273132 X31373142314731523157316231673172317731823187319231973202320732123217322232273232 X32353239324432493254325932643269327432793284328932943299330433093314331933243329 X33343339334433493354335933643369337433793382338633913396340134063411341634213426 X34313436344134463451345634613466347134763481348634913496350135063511351635213526 X35293533353835433548355335583563356835733578358335883593359836033608361336183623 X36283633363836433648365336583663366836733676368036853690369537003705371037153720 X37253730373537403745375037553760376537703775378037853790379538003805381038153820 X38233827383238373842384738523857386238673872387738823887389238973902390739123917 X39223927393239373942394739523957396239673970397439793984398939943999400440094014 X40194024402940344039404440494054405940644069407440794084408940944099410441094114 X41174121412641314136414141464151415641614166417141764181418641914196420142064211 X42164221422642314236424142464251425642614264426642684270427242744276427842804282 X42844286428842904292429442964298430043024304430643084310431243144316431843204322 X4323 X 1 2 31 32 2 3 31 32 33 3 4 32 33 34 4 5 33 34 35 5 X 6 34 35 36 6 7 35 36 37 7 8 36 37 38 8 9 37 38 39 9 X 10 38 39 40 10 11 39 40 41 11 12 40 41 42 12 13 41 42 43 13 X 14 42 43 44 14 15 43 44 45 15 16 44 45 46 16 17 45 46 47 17 X 18 46 47 48 18 19 47 48 49 19 20 48 49 50 20 21 49 50 51 21 X 22 50 51 52 22 23 51 52 53 23 24 52 53 54 24 25 53 54 55 25 X 26 54 55 56 26 27 55 56 57 27 28 56 57 58 28 29 57 58 59 29 X 30 58 59 60 30 59 60 31 32 61 62 32 33 61 62 63 33 34 62 63 X 64 34 35 63 64 65 35 36 64 65 66 36 37 65 66 67 37 38 66 67 X 68 38 39 67 68 69 39 40 68 69 70 40 41 69 70 71 41 42 70 71 X 72 42 43 71 72 73 43 44 72 73 74 44 45 73 74 75 45 46 74 75 X 76 46 47 75 76 77 47 48 76 77 78 48 49 77 78 79 49 50 78 79 X 80 50 51 79 80 81 51 52 80 81 82 52 53 81 82 83 53 54 82 83 X 84 54 55 83 84 85 55 56 84 85 86 56 57 85 86 87 57 58 86 87 X 88 58 59 87 88 89 59 60 88 89 90 60 89 90 61 62 91 92 62 63 X 91 92 93 63 64 92 93 94 64 65 93 94 95 65 66 94 95 96 66 67 X 95 96 97 67 68 96 97 98 68 69 97 98 99 69 70 98 99 100 70 71 X 99 100 101 71 72 100 101 102 72 73 101 102 103 73 74 102 103 104 74 75 X 103 104 105 75 76 104 105 106 76 77 105 106 107 77 78 106 107 108 78 79 X 107 108 109 79 80 108 109 110 80 81 109 110 111 81 82 110 111 112 82 83 X 111 112 113 83 84 112 113 114 84 85 113 114 115 85 86 114 115 116 86 87 X 115 116 117 87 88 116 117 118 88 89 117 118 119 89 90 118 119 120 90 119 X 120 91 92 121 122 92 93 121 122 123 93 94 122 123 124 94 95 123 124 125 X 95 96 124 125 126 96 97 125 126 127 97 98 126 127 128 98 99 127 128 129 X 99 100 128 129 130 100 101 129 130 131 101 102 130 131 132 102 103 131 132 133 X 103 104 132 133 134 104 105 133 134 135 105 106 134 135 136 106 107 135 136 137 X 107 108 136 137 138 108 109 137 138 139 109 110 138 139 140 110 111 139 140 141 X 111 112 140 141 142 112 113 141 142 143 113 114 142 143 144 114 115 143 144 145 X 115 116 144 145 146 116 117 145 146 147 117 118 146 147 148 118 119 147 148 149 X 119 120 148 149 150 120 149 150 121 122 151 152 122 123 151 152 153 123 124 152 X 153 154 124 125 153 154 155 125 126 154 155 156 126 127 155 156 157 127 128 156 X 157 158 128 129 157 158 159 129 130 158 159 160 130 131 159 160 161 131 132 160 X 161 162 132 133 161 162 163 133 134 162 163 164 134 135 163 164 165 135 136 164 X 165 166 136 137 165 166 167 137 138 166 167 168 138 139 167 168 169 139 140 168 X 169 170 140 141 169 170 171 141 142 170 171 172 142 143 171 172 173 143 144 172 X 173 174 144 145 173 174 175 145 146 174 175 176 146 147 175 176 177 147 148 176 X 177 178 148 149 177 178 179 149 150 178 179 180 150 179 180 151 152 181 182 152 X 153 181 182 183 153 154 182 183 184 154 155 183 184 185 155 156 184 185 186 156 X 157 185 186 187 157 158 186 187 188 158 159 187 188 189 159 160 188 189 190 160 X 161 189 190 191 161 162 190 191 192 162 163 191 192 193 163 164 192 193 194 164 X 165 193 194 195 165 166 194 195 196 166 167 195 196 197 167 168 196 197 198 168 X 169 197 198 199 169 170 198 199 200 170 171 199 200 201 171 172 200 201 202 172 X 173 201 202 203 173 174 202 203 204 174 175 203 204 205 175 176 204 205 206 176 X 177 205 206 207 177 178 206 207 208 178 179 207 208 209 179 180 208 209 210 180 X 209 210 181 182 211 212 182 183 211 212 213 183 184 212 213 214 184 185 213 214 X 215 185 186 214 215 216 186 187 215 216 217 187 188 216 217 218 188 189 217 218 X 219 189 190 218 219 220 190 191 219 220 221 191 192 220 221 222 192 193 221 222 X 223 193 194 222 223 224 194 195 223 224 225 195 196 224 225 226 196 197 225 226 X 227 197 198 226 227 228 198 199 227 228 229 199 200 228 229 230 200 201 229 230 X 231 201 202 230 231 232 202 203 231 232 233 203 204 232 233 234 204 205 233 234 X 235 205 206 234 235 236 206 207 235 236 237 207 208 236 237 238 208 209 237 238 X 239 209 210 238 239 240 210 239 240 211 212 241 242 212 213 241 242 243 213 214 X 242 243 244 214 215 243 244 245 215 216 244 245 246 216 217 245 246 247 217 218 X 246 247 248 218 219 247 248 249 219 220 248 249 250 220 221 249 250 251 221 222 X 250 251 252 222 223 251 252 253 223 224 252 253 254 224 225 253 254 255 225 226 X 254 255 256 226 227 255 256 257 227 228 256 257 258 228 229 257 258 259 229 230 X 258 259 260 230 231 259 260 261 231 232 260 261 262 232 233 261 262 263 233 234 X 262 263 264 234 235 263 264 265 235 236 264 265 266 236 237 265 266 267 237 238 X 266 267 268 238 239 267 268 269 239 240 268 269 270 240 269 270 241 242 271 272 X 242 243 271 272 273 243 244 272 273 274 244 245 273 274 275 245 246 274 275 276 X 246 247 275 276 277 247 248 276 277 278 248 249 277 278 279 249 250 278 279 280 X 250 251 279 280 281 251 252 280 281 282 252 253 281 282 283 253 254 282 283 284 X 254 255 283 284 285 255 256 284 285 286 256 257 285 286 287 257 258 286 287 288 X 258 259 287 288 289 259 260 288 289 290 260 261 289 290 291 261 262 290 291 292 X 262 263 291 292 293 263 264 292 293 294 264 265 293 294 295 265 266 294 295 296 X 266 267 295 296 297 267 268 296 297 298 268 269 297 298 299 269 270 298 299 300 X 270 299 300 271 272 301 302 272 273 301 302 303 273 274 302 303 304 274 275 303 X 304 305 275 276 304 305 306 276 277 305 306 307 277 278 306 307 308 278 279 307 X 308 309 279 280 308 309 310 280 281 309 310 311 281 282 310 311 312 282 283 311 X 312 313 283 284 312 313 314 284 285 313 314 315 285 286 314 315 316 286 287 315 X 316 317 287 288 316 317 318 288 289 317 318 319 289 290 318 319 320 290 291 319 X 320 321 291 292 320 321 322 292 293 321 322 323 293 294 322 323 324 294 295 323 X 324 325 295 296 324 325 326 296 297 325 326 327 297 298 326 327 328 298 299 327 X 328 329 299 300 328 329 330 300 329 330 301 302 331 332 302 303 331 332 333 303 X 304 332 333 334 304 305 333 334 335 305 306 334 335 336 306 307 335 336 337 307 X 308 336 337 338 308 309 337 338 339 309 310 338 339 340 310 311 339 340 341 311 X 312 340 341 342 312 313 341 342 343 313 314 342 343 344 314 315 343 344 345 315 X 316 344 345 346 316 317 345 346 347 317 318 346 347 348 318 319 347 348 349 319 X 320 348 349 350 320 321 349 350 351 321 322 350 351 352 322 323 351 352 353 323 X 324 352 353 354 324 325 353 354 355 325 326 354 355 356 326 327 355 356 357 327 X 328 356 357 358 328 329 357 358 359 329 330 358 359 360 330 359 360 331 332 361 X 362 332 333 361 362 363 333 334 362 363 364 334 335 363 364 365 335 336 364 365 X 366 336 337 365 366 367 337 338 366 367 368 338 339 367 368 369 339 340 368 369 X 370 340 341 369 370 371 341 342 370 371 372 342 343 371 372 373 343 344 372 373 X 374 344 345 373 374 375 345 346 374 375 376 346 347 375 376 377 347 348 376 377 X 378 348 349 377 378 379 349 350 378 379 380 350 351 379 380 381 351 352 380 381 X 382 352 353 381 382 383 353 354 382 383 384 354 355 383 384 385 355 356 384 385 X 386 356 357 385 386 387 357 358 386 387 388 358 359 387 388 389 359 360 388 389 X 390 360 389 390 361 362 391 392 362 363 391 392 393 363 364 392 393 394 364 365 X 393 394 395 365 366 394 395 396 366 367 395 396 397 367 368 396 397 398 368 369 X 397 398 399 369 370 398 399 400 370 371 399 400 401 371 372 400 401 402 372 373 X 401 402 403 373 374 402 403 404 374 375 403 404 405 375 376 404 405 406 376 377 X 405 406 407 377 378 406 407 408 378 379 407 408 409 379 380 408 409 410 380 381 X 409 410 411 381 382 410 411 412 382 383 411 412 413 383 384 412 413 414 384 385 X 413 414 415 385 386 414 415 416 386 387 415 416 417 387 388 416 417 418 388 389 X 417 418 419 389 390 418 419 420 390 419 420 391 392 421 422 392 393 421 422 423 X 393 394 422 423 424 394 395 423 424 425 395 396 424 425 426 396 397 425 426 427 X 397 398 426 427 428 398 399 427 428 429 399 400 428 429 430 400 401 429 430 431 X 401 402 430 431 432 402 403 431 432 433 403 404 432 433 434 404 405 433 434 435 X 405 406 434 435 436 406 407 435 436 437 407 408 436 437 438 408 409 437 438 439 X 409 410 438 439 440 410 411 439 440 441 411 412 440 441 442 412 413 441 442 443 X 413 414 442 443 444 414 415 443 444 445 415 416 444 445 446 416 417 445 446 447 X 417 418 446 447 448 418 419 447 448 449 419 420 448 449 450 420 449 450 421 422 X 451 452 422 423 451 452 453 423 424 452 453 454 424 425 453 454 455 425 426 454 X 455 456 426 427 455 456 457 427 428 456 457 458 428 429 457 458 459 429 430 458 X 459 460 430 431 459 460 461 431 432 460 461 462 432 433 461 462 463 433 434 462 X 463 464 434 435 463 464 465 435 436 464 465 466 436 437 465 466 467 437 438 466 X 467 468 438 439 467 468 469 439 440 468 469 470 440 441 469 470 471 441 442 470 X 471 472 442 443 471 472 473 443 444 472 473 474 444 445 473 474 475 445 446 474 X 475 476 446 447 475 476 477 447 448 476 477 478 448 449 477 478 479 449 450 478 X 479 480 450 479 480 451 452 481 482 452 453 481 482 483 453 454 482 483 484 454 X 455 483 484 485 455 456 484 485 486 456 457 485 486 487 457 458 486 487 488 458 X 459 487 488 489 459 460 488 489 490 460 461 489 490 491 461 462 490 491 492 462 X 463 491 492 493 463 464 492 493 494 464 465 493 494 495 465 466 494 495 496 466 X 467 495 496 497 467 468 496 497 498 468 469 497 498 499 469 470 498 499 500 470 X 471 499 500 501 471 472 500 501 502 472 473 501 502 503 473 474 502 503 504 474 X 475 503 504 505 475 476 504 505 506 476 477 505 506 507 477 478 506 507 508 478 X 479 507 508 509 479 480 508 509 510 480 509 510 481 482 511 512 482 483 511 512 X 513 483 484 512 513 514 484 485 513 514 515 485 486 514 515 516 486 487 515 516 X 517 487 488 516 517 518 488 489 517 518 519 489 490 518 519 520 490 491 519 520 X 521 491 492 520 521 522 492 493 521 522 523 493 494 522 523 524 494 495 523 524 X 525 495 496 524 525 526 496 497 525 526 527 497 498 526 527 528 498 499 527 528 X 529 499 500 528 529 530 500 501 529 530 531 501 502 530 531 532 502 503 531 532 X 533 503 504 532 533 534 504 505 533 534 535 505 506 534 535 536 506 507 535 536 X 537 507 508 536 537 538 508 509 537 538 539 509 510 538 539 540 510 539 540 511 X 512 541 542 512 513 541 542 543 513 514 542 543 544 514 515 543 544 545 515 516 X 544 545 546 516 517 545 546 547 517 518 546 547 548 518 519 547 548 549 519 520 X 548 549 550 520 521 549 550 551 521 522 550 551 552 522 523 551 552 553 523 524 X 552 553 554 524 525 553 554 555 525 526 554 555 556 526 527 555 556 557 527 528 X 556 557 558 528 529 557 558 559 529 530 558 559 560 530 531 559 560 561 531 532 X 560 561 562 532 533 561 562 563 533 534 562 563 564 534 535 563 564 565 535 536 X 564 565 566 536 537 565 566 567 537 538 566 567 568 538 539 567 568 569 539 540 X 568 569 570 540 569 570 541 542 571 572 542 543 571 572 573 543 544 572 573 574 X 544 545 573 574 575 545 546 574 575 576 546 547 575 576 577 547 548 576 577 578 X 548 549 577 578 579 549 550 578 579 580 550 551 579 580 581 551 552 580 581 582 X 552 553 581 582 583 553 554 582 583 584 554 555 583 584 585 555 556 584 585 586 X 556 557 585 586 587 557 558 586 587 588 558 559 587 588 589 559 560 588 589 590 X 560 561 589 590 591 561 562 590 591 592 562 563 591 592 593 563 564 592 593 594 X 564 565 593 594 595 565 566 594 595 596 566 567 595 596 597 567 568 596 597 598 X 568 569 597 598 599 569 570 598 599 600 570 599 600 571 572 601 602 572 573 601 X 602 603 573 574 602 603 604 574 575 603 604 605 575 576 604 605 606 576 577 605 X 606 607 577 578 606 607 608 578 579 607 608 609 579 580 608 609 610 580 581 609 X 610 611 581 582 610 611 612 582 583 611 612 613 583 584 612 613 614 584 585 613 X 614 615 585 586 614 615 616 586 587 615 616 617 587 588 616 617 618 588 589 617 X 618 619 589 590 618 619 620 590 591 619 620 621 591 592 620 621 622 592 593 621 X 622 623 593 594 622 623 624 594 595 623 624 625 595 596 624 625 626 596 597 625 X 626 627 597 598 626 627 628 598 599 627 628 629 599 600 628 629 630 600 629 630 X 601 602 631 632 602 603 631 632 633 603 604 632 633 634 604 605 633 634 635 605 X 606 634 635 636 606 607 635 636 637 607 608 636 637 638 608 609 637 638 639 609 X 610 638 639 640 610 611 639 640 641 611 612 640 641 642 612 613 641 642 643 613 X 614 642 643 644 614 615 643 644 645 615 616 644 645 646 616 617 645 646 647 617 X 618 646 647 648 618 619 647 648 649 619 620 648 649 650 620 621 649 650 651 621 X 622 650 651 652 622 623 651 652 653 623 624 652 653 654 624 625 653 654 655 625 X 626 654 655 656 626 627 655 656 657 627 628 656 657 658 628 629 657 658 659 629 X 630 658 659 660 630 659 660 631 632 661 662 632 633 661 662 663 633 634 662 663 X 664 634 635 663 664 665 635 636 664 665 666 636 637 665 666 667 637 638 666 667 X 668 638 639 667 668 669 639 640 668 669 670 640 641 669 670 671 641 642 670 671 X 672 642 643 671 672 673 643 644 672 673 674 644 645 673 674 675 645 646 674 675 X 676 646 647 675 676 677 647 648 676 677 678 648 649 677 678 679 649 650 678 679 X 680 650 651 679 680 681 651 652 680 681 682 652 653 681 682 683 653 654 682 683 X 684 654 655 683 684 685 655 656 684 685 686 656 657 685 686 687 657 658 686 687 X 688 658 659 687 688 689 659 660 688 689 690 660 689 690 661 662 691 692 662 663 X 691 692 693 663 664 692 693 694 664 665 693 694 695 665 666 694 695 696 666 667 X 695 696 697 667 668 696 697 698 668 669 697 698 699 669 670 698 699 700 670 671 X 699 700 701 671 672 700 701 702 672 673 701 702 703 673 674 702 703 704 674 675 X 703 704 705 675 676 704 705 706 676 677 705 706 707 677 678 706 707 708 678 679 X 707 708 709 679 680 708 709 710 680 681 709 710 711 681 682 710 711 712 682 683 X 711 712 713 683 684 712 713 714 684 685 713 714 715 685 686 714 715 716 686 687 X 715 716 717 687 688 716 717 718 688 689 717 718 719 689 690 718 719 720 690 719 X 720 691 692 721 722 692 693 721 722 723 693 694 722 723 724 694 695 723 724 725 X 695 696 724 725 726 696 697 725 726 727 697 698 726 727 728 698 699 727 728 729 X 699 700 728 729 730 700 701 729 730 731 701 702 730 731 732 702 703 731 732 733 X 703 704 732 733 734 704 705 733 734 735 705 706 734 735 736 706 707 735 736 737 X 707 708 736 737 738 708 709 737 738 739 709 710 738 739 740 710 711 739 740 741 X 711 712 740 741 742 712 713 741 742 743 713 714 742 743 744 714 715 743 744 745 X 715 716 744 745 746 716 717 745 746 747 717 718 746 747 748 718 719 747 748 749 X 719 720 748 749 750 720 749 750 721 722 751 752 722 723 751 752 753 723 724 752 X 753 754 724 725 753 754 755 725 726 754 755 756 726 727 755 756 757 727 728 756 X 757 758 728 729 757 758 759 729 730 758 759 760 730 731 759 760 761 731 732 760 X 761 762 732 733 761 762 763 733 734 762 763 764 734 735 763 764 765 735 736 764 X 765 766 736 737 765 766 767 737 738 766 767 768 738 739 767 768 769 739 740 768 X 769 770 740 741 769 770 771 741 742 770 771 772 742 743 771 772 773 743 744 772 X 773 774 744 745 773 774 775 745 746 774 775 776 746 747 775 776 777 747 748 776 X 777 778 748 749 777 778 779 749 750 778 779 780 750 779 780 751 752 781 782 752 X 753 781 782 783 753 754 782 783 784 754 755 783 784 785 755 756 784 785 786 756 X 757 785 786 787 757 758 786 787 788 758 759 787 788 789 759 760 788 789 790 760 X 761 789 790 791 761 762 790 791 792 762 763 791 792 793 763 764 792 793 794 764 X 765 793 794 795 765 766 794 795 796 766 767 795 796 797 767 768 796 797 798 768 X 769 797 798 799 769 770 798 799 800 770 771 799 800 801 771 772 800 801 802 772 X 773 801 802 803 773 774 802 803 804 774 775 803 804 805 775 776 804 805 806 776 X 777 805 806 807 777 778 806 807 808 778 779 807 808 809 779 780 808 809 810 780 X 809 810 781 782 811 812 782 783 811 812 813 783 784 812 813 814 784 785 813 814 X 815 785 786 814 815 816 786 787 815 816 817 787 788 816 817 818 788 789 817 818 X 819 789 790 818 819 820 790 791 819 820 821 791 792 820 821 822 792 793 821 822 X 823 793 794 822 823 824 794 795 823 824 825 795 796 824 825 826 796 797 825 826 X 827 797 798 826 827 828 798 799 827 828 829 799 800 828 829 830 800 801 829 830 X 831 801 802 830 831 832 802 803 831 832 833 803 804 832 833 834 804 805 833 834 X 835 805 806 834 835 836 806 807 835 836 837 807 808 836 837 838 808 809 837 838 X 839 809 810 838 839 840 810 839 840 811 812 841 842 812 813 841 842 843 813 814 X 842 843 844 814 815 843 844 845 815 816 844 845 846 816 817 845 846 847 817 818 X 846 847 848 818 819 847 848 849 819 820 848 849 850 820 821 849 850 851 821 822 X 850 851 852 822 823 851 852 853 823 824 852 853 854 824 825 853 854 855 825 826 X 854 855 856 826 827 855 856 857 827 828 856 857 858 828 829 857 858 859 829 830 X 858 859 860 830 831 859 860 861 831 832 860 861 862 832 833 861 862 863 833 834 X 862 863 864 834 835 863 864 865 835 836 864 865 866 836 837 865 866 867 837 838 X 866 867 868 838 839 867 868 869 839 840 868 869 870 840 869 870 841 842 871 872 X 842 843 871 872 873 843 844 872 873 874 844 845 873 874 875 845 846 874 875 876 X 846 847 875 876 877 847 848 876 877 878 848 849 877 878 879 849 850 878 879 880 X 850 851 879 880 881 851 852 880 881 882 852 853 881 882 883 853 854 882 883 884 X 854 855 883 884 885 855 856 884 885 886 856 857 885 886 887 857 858 886 887 888 X 858 859 887 888 889 859 860 888 889 890 860 861 889 890 891 861 862 890 891 892 X 862 863 891 892 893 863 864 892 893 894 864 865 893 894 895 865 866 894 895 896 X 866 867 895 896 897 867 868 896 897 898 868 869 897 898 899 869 870 898 899 900 X 870 899 900 871 872 872 873 873 874 874 875 875 876 876 877 877 878 878 879 879 X 880 880 881 881 882 882 883 883 884 884 885 885 886 886 887 887 888 888 889 889 X 890 890 891 891 892 892 893 893 894 894 895 895 896 896 897 897 898 898 899 899 X 900 900 X 8.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 X -1.0 -1.0 8.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 X -1.0 -1.0 8.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 8.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 X -1.0 -1.0 -1.0 8.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 -1.0 -1.0 8.0 -1.0 -1.0 -1.0 -1.0 X 8.0 -1.0 -1.0 8.0 -1.0 8.0 -1.0 8.0 -1.0 8.0 X -1.0 8.0 -1.0 8.0 -1.0 8.0 -1.0 8.0 -1.0 8.0 X -1.0 8.0 -1.0 8.0 -1.0 8.0 -1.0 8.0 -1.0 8.0 X -1.0 8.0 -1.0 8.0 -1.0 8.0 -1.0 8.0 -1.0 8.0 X -1.0 8.0 -1.0 8.0 -1.0 8.0 -1.0 8.0 -1.0 8.0 X -1.0 8.0 -1.0 8.0 -1.0 8.0 -1.0 8.0 -1.0 8.0 X -1.0 8.0 END_OF_FILE if test 56700 -ne `wc -c <'gr3030'`; then echo shar: \"'gr3030'\" unpacked with wrong size! fi # end of 'gr3030' fi if test -f 'init.data.example' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'init.data.example'\" else echo shar: Extracting \"'init.data.example'\" \(5328 characters\) sed "s/^X//" >'init.data.example' <<'END_OF_FILE' X# Input/Output parameters for the driver runme. X# If this file is improperly set, there will be I/O errors. X# As a precaution, keep infolevel as the first parameter and use a value X# of 5 (debug mode) to see how this file is being read -- VERY USEFUL in X# order to detect and fix I/O errors. The value of 5 will produce X# a very long output. Specify an output file (see outfile below) or X# use the UNIX redirection command (>) to capture the output in a file. X# X# The keyword that denotes a parameter and its corresponding value X# must start at the first column. Moreover, the keyword must end X# with a colon (:) X# X# Lines without a proper keyword are consider as comment lines. X X#-------------------------------------------------------------------------- X# infolevel - Information Level (default = 1) X# The infolevel parameter specifies the amount of information to be reported X# X# 0 = Silent running X# X# 1 = print Iteration info (compact mode for outer iteration) X# Use this to see quantities at the end of each iteration X# X# 2 = print Sub-iteration info (compact mode for inner-iteration) X# Use this to see a detailed history of the residual and block-size X# X# 3,4 = print Convergence info (medium mode) X# Use this to see the evolution of individual Ritz values and X# residual norms X# X# 5 = debug mode (highly verbose) X# Very long output. Specify an output file (see outfile below). X# Alternatively, you can use the UNIX redirection command (>) on the X# prompt to capture the output in a file. You should also set the X# number of iteration to 1 just to see the output at the first X# iteration. X# X# EXPLANATIONS ABOUT THE QUANTITIES THAT ARE REPORTED X# =================================================== X# X# compact mode when infolevel = 1,2, the following variables are printed X# ------------ X# iter : current number of iterations. X# basis : current size of the basis. X# nmult : current number of matrix-vector multiplications used. X# block : current block size. X# nevf : number of eigenpairs found so far. X# residual : maximum among residual norms. X# X# medium mode when infolvel = 3,4, display further scalar quantities X# ----------- X# current Ritz values X# current residual norms X# X# verbose mode when infolevel = 5, display also vector & matrix quantities X# ------------ X# current Ritz vectors X# current Interaction matrix X# current basis vectors X# current eigen vectors X# current residual vectors X Xinfolevel: X1 X X#-------------------------------------------------------------------------- X# Matrix filename. Only one matrix at a time. X# Relative or full path to the file containing the matrix X Xmatfile: Xgr3030 X X#-------------------------------------------------------------------------- X#Set the matrix type X# hbo = Harwell-Boeing storage format (default) X# ccs = Compressed Column Storage format X# coo = COOrdinates storage format X X#mattype: X#hbo X X#-------------------------------------------------------------------------- X#Set the block size (default = 1) X X#block: X#3 X X#-------------------------------------------------------------------------- X#Set number of wanted eigenpairs (default = 1) X#a positive value searches for the rightmost eigenpairs X#a negative value searches for the leftmost eigenpairs X X#eigenpair: X#-3 X X#-------------------------------------------------------------------------- X#Choose the corrector (preconditioner) X# 0 = no internal correction (NC) X# 1 = diagonal correction (DC) (default) X# 2 = tridiagonal correction (TC) X# 3 = pentadiagonal correction (PC) X# -1 = Gauss-Seidel correction (GS) X# -2 = Incomplete Cholesky correction (IC) X# -3 = Exponential correction (EX) X X#corrector: X#3 X X#-------------------------------------------------------------------------- X# Set size of the basis (default = 40) X# The value should not exceed the maximum value declared in the main program X X#basis: X#30 X X#-------------------------------------------------------------------------- X# Set maximun allowable number of iterations (default = 100) X X#iteration: X#150 X X#-------------------------------------------------------------------------- X# Set tolerance (default = 1.0d-7) X X#tolerance: X#1.0d-10 X X#-------------------------------------------------------------------------- X# Number of rows of eigenvectors and residual vectors to show (default = 5) X# A negative value -k causes the last k rows to be written X X#outmax: X#-7 X X#-------------------------------------------------------------------------- X# Set output format X# The syntax should be as expected by the Fortran compiler X Xoutfmt: X1P,E11.3 X X#-------------------------------------------------------------------------- X# Initial guess file for starting eigenvectors (default = unspecified) X# If unspecified, guesses are generated internally with a random function X# If specified, guesses are read from the file in the standard matrix-wise X# tabulation X X#guessfile: X#guess X X#-------------------------------------------------------------------------- X# Name of a file for error messages (default = screen) X# Relative or full path to the file X X#errfile: X#error X X#-------------------------------------------------------------------------- X# Name of a file for output of results (default = screen) X# Relative or full path to the file X X#outfile: X#output END_OF_FILE if test 5328 -ne `wc -c <'init.data.example'`; then echo shar: \"'init.data.example'\" unpacked with wrong size! fi # end of 'init.data.example' fi if test -f 'Makefile' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'Makefile'\" else echo shar: Extracting \"'Makefile'\" \(1483 characters\) sed "s/^X//" >'Makefile' <<'END_OF_FILE' X#--- type `make alone' to build the self-contained standalone driver X#--- type `make runme' to build the comprehensive driver X X# COMPILER X########################################################################### XFC = g77 X#FC = f77 X X# COMPILER FLAGS: X########################################################################### X#Comment the first assignment and uncomment the second one if your are on X#SGI to ensure that SGI optimizations preserve IEEE requirements XFFLAGS = -O3 X#FFLAGS = -O3 -OPT:IEEE_arithmetic=1 X X# LIBRARIES X########################################################################### X# Among the 3 possibilities below, uncomment the appropriate X# case for your environment and comment the others. X X# case 1: works when LAPACK and BLAS are installed. X#OBJLIBS = X#LIBS = -llapack -lblas X#LIBS = -lcomplib.sgimath X X# case 2: works when LAPACK is not installed but BLAS is. X#LIBS = -lblas X#OBJLIBS = lapack.o X X# case 3: works when neither LAPACK nor BLAS are installed. XOBJLIBS = blas.o lapack.o XLIBS = X X# RULES X########################################################################### X XALONE = randm.o eigsrt.o davpack.o $(OBJLIBS) X Xalone: $(ALONE) alone.o X $(FC) $(FFLAGS) -o $@ alone.o $(ALONE) $(LIBS) X X#--- X XRUNME = randm.o io.o getmat.o matvec.o correc.o ichol.o \ X eigsrt.o davpack.o $(OBJLIBS) X Xrunme: $(RUNME) runme.o expokit.o X $(FC) $(FFLAGS) -o $@ runme.o expokit.o $(RUNME) $(LIBS) X X#--- X X.f.o:; $(FC) $(FFLAGS) -c $< X X END_OF_FILE if test 1483 -ne `wc -c <'Makefile'`; then echo shar: \"'Makefile'\" unpacked with wrong size! fi # end of 'Makefile' fi if test -f 'common.inc' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'common.inc'\" else echo shar: Extracting \"'common.inc'\" \(3516 characters\) sed "s/^X//" >'common.inc' <<'END_OF_FILE' X*----------------------------------------------------------------------| X* FILE X* common.inc - Common variables X* X* DESCRIPTION X* X* Common variables that are included in subroutines with the X* statement: include 'common.inc'. The inclusion is done in the X* driver runme.f and all subroutines of: X* correc.f, getmat.f, io.f, matvec.f. X* X* To avoid inadvertent mis-use and to enable a better identification X* subsequently, common variables are prefixed with `c_' X* X* END DESCRIPTION X*----------------------------------------------------------------------| X* X* AUTHORS X* X* M. Sadkane - sadkane@univ-brest.fr R. B. Sidje - rbs@maths.uq.edu.au X* Departement de Mathematiques Department of Mathematics X* Universite de Bretagne Occidentale University of Queensland X* 6, Avenue Le Gorgeu, B.P. 809 Brisbane QLD 4072 X* 29285 Brest Cedex. France Australia X* X* REVISION DATE: 11/JAN/1999 X*----------------------------------------------------------------------| X X implicit none X*----------------------------------------------------------------------| X*--- These settings are large enough for all the matrices in X*--- the Harwell-Boeing collection as of March 28, 1994, except X*--- bcsstk30, 31, and 32 in bcsstuc5.data. X integer c_nmax, c_nzmax, c_n, c_nz X parameter( c_nmax=15500, c_nzmax=550000 ) X X*----------------------------------------------------------------------| X*--- Adjust as suited for your matrices ... X double precision c_a(c_nzmax), c_anorm X integer c_ia(c_nzmax), c_ja(c_nzmax) X X common /MATRIX/ X . c_anorm, X . c_a, X . c_ia, X . c_ja, X . c_nz, X . c_n X X*----------------------------------------------------------------------| X*--- Adjust as suited for your correctors/preconditioners ... X X*--- Diagonal / Tridiagonal / Pentadiagonal correctors X double precision c_diag(c_nmax,3) X X*--- Choleski (LDL^T variant) corrector X double precision c_ac(c_nzmax) X integer c_ic(c_nzmax), c_jc(c_nmax+1) X X common /CORRECTOR/ X . c_diag, c_ac, c_ic, c_jc X X*----------------------------------------------------------------------| X*--- Arrays used for speedy work ... X double precision c_wrk(7*c_nmax) X integer c_iwrk(c_nmax) X common /WRK/ X . c_wrk, X . c_iwrk X X*----------------------------------------------------------------------| X*--- This remaining part is unlikely to be changed ... X X double precision c_tol X X integer c_stdin, c_stdout, c_stderr, c_outmax, X . c_corrector, c_basis, c_block, c_eigenpair, X . c_iteration, c_infolevel, c_nmult, c_guess X X character*80 c_matfile, c_mattype, c_outfmt, X . c_initfile, c_guessfile, c_errfile, c_outfile X X*----------------------------------------------------------------------| X common /FLOATS/ X . c_tol X X common /INTEGERS/ X . c_stdin, X . c_stdout, X . c_stderr, X . c_infolevel, X . c_corrector, X . c_nmult, X . c_guess, X . c_basis, X . c_block, X . c_eigenpair, X . c_iteration, X . c_outmax X X common /STRINGS/ X . c_outfmt, X . c_matfile, X . c_mattype, X . c_initfile, X . c_guessfile, X . c_errfile, X . c_outfile X*----------------------------------------------------------------------| X END_OF_FILE if test 3516 -ne `wc -c <'common.inc'`; then echo shar: \"'common.inc'\" unpacked with wrong size! fi # end of 'common.inc' fi if test -f 'alone.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'alone.f'\" else echo shar: Extracting \"'alone.f'\" \(10503 characters\) sed "s/^X//" >'alone.f' <<'END_OF_FILE' X*----------------------------------------------------------------------| X* FILE X* alone.f - stand-alone driver using internal data - X* This is an example of a self-contained stand-alone X* driver that illustrates the use of the Variable-Block X* Davidson eigensolver in isolation. X* X* Complile with "make alone" and simply type "alone" to run the code X* X* The program will start by generating a random matrix as follows: X* A = [a_ij] where: (Example 5.5 in Crouzeix et al.) X* a_ii = random in [-10,+10] X* random in [-1,+1], with probability alpha X* a_ij = < X* 0, with probability 1-alpha (alpha was taken as 0.01) X* X* The COOrdinates storage is used, thus three arrays are built: X* ia(1:nz) contains row indices, ja(1:nz) contains column indices, X* and a(1:nz) contains non-zero values, where nz is the number of X* non-zeros. During the generation, the diagonal of A is stored in X* diag(1:n) which is used later for diagonal correction. X* X* After generating the matrix and the corrector, the program then X* proceeds to initialize all the input arguments expected in the X* Davidson eigensolver: X* nbx = maximum allowable size of the basis X* nb = initial block-size X* nev = number of wanted eigenpairs X* itmax = maximum allowable number of iterations (i.e., restarts) X* tol = accuracy tolerance X* ilevel = level of information to be reported X* iunit = unit where the information should be reported (6 = screen) X* anorm = estimate of some norm of A. This parameter provides a X* means to select a particular convergence test: X* - If anorm>0.0d0, an eigenpair (x,lambda) is accepted if X* the relative residual ||A*x - lambda*x||/anorm <= tol. X* - If anorm=1.0d0, the test is therefore based on the X* absolute residual ||A*x - lambda*x|| <= tol. X* - If anorm=0.0d0, the code uses the relative residual X* ||A*x - lambda*x||/MAX(eps^{2/3},ABS(lambda)) <= tol. X* `eps' is the machine unit roundoff (computed internally) X* X* After these initializations, the eigensolver itself is called. X* Then the computed eigenpairs are sorted and the results printed. X* X* CONTENTS X* subroutine mymatv(m,x,ldx,y,ldy) - block matrix-vector product X* subroutine mycorr(m,ritzv,x,ldx,r,ldr) - diagonal corrector X* double precision function timer( ) - simple utility timer routine X* X* CALLED ROUTINES X* davpack.f: davson(...) - Variable-Block Davidson with deflation X* randm.f: DLARAN( ISEED ) - uniform (0,1) random number generator X* DLARAN is taken from the LAPACK testing suite. X* eigsrt.f: eigsrt( n, nev, res, eig, x,ldx ) - sorts eigenpairs X* internal: timer( ) - simple utility timer routine (seconds) X* X* DESCRIPTION X* X* #####################################################################| X* subroutine mymatv( m, x,ldx, y,ldy ) X* Purpose X* Block matrix-vector multiplication using the COOrdinate storage. X* Although A is a symmetric matrix, it is in a complete (not half) X* format. The matrix A is passed through a common block. X* Called Routines X* -none- X* X* #####################################################################| X* subroutine mycorr( m, ritzv, x,ldx, r,ldr ) X* Purpose X* Diagonal corrector. X* computes r_j = (M-ritzv(j)*I)\r_j for j = 1:m, where M = diag(A) X* The diagonal of A is passed through a common block. X* Called Routines X* -none- X* X* #####################################################################| X* double precision function timer( ) X* Purpose X* This is a simple utility timer routine (seconds) modelled on top X* of SUN' etime function. Users must change the call to "etime" X* as appropriate to suit their environments. X* X* END DESCRIPTION X*----------------------------------------------------------------------| X* X* AUTHORS X* X* M. Sadkane - sadkane@univ-brest.fr R. B. Sidje - rbs@maths.uq.edu.au X* Departement de Mathematiques Department of Mathematics X* Universite de Bretagne Occidentale University of Queensland X* 6, Avenue Le Gorgeu, B.P. 809 Brisbane QLD 4072 X* 29285 Brest Cedex. France Australia X* X* REVISION DATE: 11/JAN/1999 X*----------------------------------------------------------------------| X X IMPLICIT NONE X external mymatv, mycorr X X*--- Matrix and Corrector (diagonal correction) ... X X integer n, nz, nmax, nzmax, nmult X parameter( nmax =5000, nzmax =100000 ) X integer ia(nzmax), ja(nzmax) X double precision diag(nmax), a(nzmax) X common /MATRIX/ diag, a, ia, ja, n, nz X X*--- Arguments of DAVSON ... X integer nevmax, nbxmax, liwork, lwork, ldx X parameter( ldx=nmax, nevmax=10, nbxmax=50 ) X parameter( liwork=6*nbxmax, X . lwork = (nmax+nbxmax)*(nevmax+nbxmax)+(nmax+8)*nbxmax ) X X integer nbx, nb, nev, itmax, iter, ilevel, iunit X integer iwork(liwork), ifail X double precision res(nevmax), eig(nevmax), x(ldx,nevmax) X double precision work(lwork), tol, anorm X X*--- other variables ... X integer nev1, i, j, iseed(4) X double precision alpha, t0, t1 X X*--- functions X double precision timer, dlaran X intrinsic ABS X X*======================================================================| X*--- Setup the matrix ... (Example 5.5 in Crouzeix et al.) X* The COOrdinates format is used. X* X write(*,*) 'Generating the matrix ...' X n = 1000 X alpha = 0.01d0 X nz = 0 X iseed(1) = 0 X iseed(2) = 0 X iseed(3) = 0 X iseed(4) = 7 X*-- generate the diagonal ... X do i = 1,n X nz = nz + 1 X ia(nz) = i X ja(nz) = i X a(nz) = 20.0d0*DLARAN( iseed ) - 10.0d0 X diag(i) = a(nz) X enddo X*--- generate the lower part ... X do j = 1,n X do i = 1,j-1 X if ( nz.ge.nzmax ) stop 'Please increase nzmax' X if ( DLARAN( iseed ).le.alpha ) then X nz = nz + 1 X ia(nz) = i X ja(nz) = j X a(nz) = 2.0d0*DLARAN( iseed ) - 1.0d0 X endif X enddo X enddo X*--- include the upper-part in the COOrdinates format ... X j = nz X do i = 1,j X if ( ia(i).ne.ja(i) ) then X if ( nz.ge.nzmax ) stop 'Please increase nzmax' X nz = nz + 1 X a(nz) = a(i) X ja(nz) = ia(i) X ia(nz) = ja(i) X endif X enddo X X*======================================================================| X*--- Setup input arguments of DAVSON ... X nbx = 20 X nb = 2 X nev = 1 X itmax = 100 X tol = 1.0D-10 X ilevel = 2 X iunit = 6 X anorm = 1.0d0 X X*======================================================================| X*--- Initial estimate eigenvectors ... (random generation) X iseed(1) = 1 X iseed(2) = 3 X iseed(3) = 5 X iseed(4) = 7 X do j = 1,nb X do i = 1,n X x(i,j) = DLARAN( iseed ) X enddo X enddo X X*======================================================================| X*--- Compute the desired eigenpairs ... X nev1 = nev X t0 = timer( ) X call davson( n, nbx, nb, nev1, itmax, iter, nmult, tol, X . anorm, res, eig, x,ldx, work,lwork, iwork,liwork, X . mymatv, mycorr, ilevel, iunit, ifail ) X t1 = timer( ) X X*======================================================================| X*--- Sort the eigenpairs in increasing order ... X call eigsrt( n, ABS(nev), res, eig, x,ldx ) X X*======================================================================| X*--- Output results ... X write(*,*) 'Runtime (seconds) =', t1-t0 X write(*,*) 'Mat-vec products =', nmult X write(*,*) 'Residual =', res(1) X write(*,*) 'Eigenvalue =', eig(1) X X*======================================================================| X*--- WARNING: on a SUN system, at the end of the output, the following X* note may appear (without affecting the correctness of the results) X*--- X* Note: the following IEEE floating-point arithmetic exceptions X* occurred and were never cleared; see ieee_flags(3M): X* Inexact; Underflow; X* Sun's implementation of IEEE arithmetic is discussed in X* the Numerical Computation Guide. X*--- X end X*----------------------------------------------------------------------| X*::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::| X*::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::| X*::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::| X*----------------------------------------------------------------------| X subroutine mymatv( m, x,ldx, y,ldy ) X implicit none X* X integer m, ldx, ldy X double precision x(ldx,m), y(ldy,m) X* X*--- computes y = A*x, A is a complete (not half) COOrdinate matrix... X* X*--- Matrix data and corrector ... X integer n, nz, nmax, nzmax X parameter( nmax =5000, nzmax =100000 ) X integer ia(nzmax), ja(nzmax) X double precision diag(nmax), a(nzmax) X common /MATRIX/ diag, a, ia, ja, n, nz X* X integer i, k X* X do k = 1,m X do i = 1,n X y(i,k) = 0.0d0 X enddo X enddo X do i = 1,nz X do k = 1,m X y(ia(i),k) = y(ia(i),k) + a(i)*x(ja(i),k) X enddo X enddo X end X*----------------------------------------------------------------------| X subroutine mycorr( m, ritzv, x,ldx, r,ldr ) X implicit none X* X integer m, ldx, ldr X double precision x(ldx,m), r(ldr,m), ritzv(m) X* X*--- Diagonal correction ... X* X*--- Matrix data and corrector ... X integer n, nz, nmax, nzmax X parameter( nmax =5000, nzmax =100000 ) X integer ia(nzmax), ja(nzmax) X double precision diag(nmax), a(nzmax) X common /MATRIX/ diag, a, ia, ja, n, nz X* X integer i, j X double precision tmp X X do j = 1,m X do i = 1,n X tmp = diag(i) - ritzv(j) X if ( tmp.ne.0.0d0 ) r(i,j) = r(i,j)/tmp X enddo X enddo X end X*----------------------------------------------------------------------| X*--- Simple utility timer routine (seconds) X* Modify as appropriate to suit your environment X double precision function timer( ) X real*4 etime, tm(2) X timer = etime( tm ) X end END_OF_FILE if test 10503 -ne `wc -c <'alone.f'`; then echo shar: \"'alone.f'\" unpacked with wrong size! fi # end of 'alone.f' fi if test -f 'blas.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'blas.f'\" else echo shar: Extracting \"'blas.f'\" \(103779 characters\) sed "s/^X//" >'blas.f' <<'END_OF_FILE' X subroutine daxpy(n,da,dx,incx,dy,incy) Xc Xc constant times a vector plus a vector. Xc uses unrolled loops for increments equal to one. Xc jack dongarra, linpack, 3/11/78. Xc modified 12/3/93, array(1) declarations changed to array(*) Xc X double precision dx(*),dy(*),da X integer i,incx,incy,ix,iy,m,mp1,n Xc X if(n.le.0)return X if (da .eq. 0.0d0) return X if(incx.eq.1.and.incy.eq.1)go to 20 Xc Xc code for unequal increments or equal increments Xc not equal to 1 Xc X ix = 1 X iy = 1 X if(incx.lt.0)ix = (-n+1)*incx + 1 X if(incy.lt.0)iy = (-n+1)*incy + 1 X do 10 i = 1,n X dy(iy) = dy(iy) + da*dx(ix) X ix = ix + incx X iy = iy + incy X 10 continue X return Xc Xc code for both increments equal to 1 Xc Xc Xc clean-up loop Xc X 20 m = mod(n,4) X if( m .eq. 0 ) go to 40 X do 30 i = 1,m X dy(i) = dy(i) + da*dx(i) X 30 continue X if( n .lt. 4 ) return X 40 mp1 = m + 1 X do 50 i = mp1,n,4 X dy(i) = dy(i) + da*dx(i) X dy(i + 1) = dy(i + 1) + da*dx(i + 1) X dy(i + 2) = dy(i + 2) + da*dx(i + 2) X dy(i + 3) = dy(i + 3) + da*dx(i + 3) X 50 continue X return X end X subroutine dcopy(n,dx,incx,dy,incy) Xc Xc copies a vector, x, to a vector, y. Xc uses unrolled loops for increments equal to one. Xc jack dongarra, linpack, 3/11/78. Xc modified 12/3/93, array(1) declarations changed to array(*) Xc X double precision dx(*),dy(*) X integer i,incx,incy,ix,iy,m,mp1,n Xc X if(n.le.0)return X if(incx.eq.1.and.incy.eq.1)go to 20 Xc Xc code for unequal increments or equal increments Xc not equal to 1 Xc X ix = 1 X iy = 1 X if(incx.lt.0)ix = (-n+1)*incx + 1 X if(incy.lt.0)iy = (-n+1)*incy + 1 X do 10 i = 1,n X dy(iy) = dx(ix) X ix = ix + incx X iy = iy + incy X 10 continue X return Xc Xc code for both increments equal to 1 Xc Xc Xc clean-up loop Xc X 20 m = mod(n,7) X if( m .eq. 0 ) go to 40 X do 30 i = 1,m X dy(i) = dx(i) X 30 continue X if( n .lt. 7 ) return X 40 mp1 = m + 1 X do 50 i = mp1,n,7 X dy(i) = dx(i) X dy(i + 1) = dx(i + 1) X dy(i + 2) = dx(i + 2) X dy(i + 3) = dx(i + 3) X dy(i + 4) = dx(i + 4) X dy(i + 5) = dx(i + 5) X dy(i + 6) = dx(i + 6) X 50 continue X return X end X double precision function ddot(n,dx,incx,dy,incy) Xc Xc forms the dot product of two vectors. Xc uses unrolled loops for increments equal to one. Xc jack dongarra, linpack, 3/11/78. Xc modified 12/3/93, array(1) declarations changed to array(*) Xc X double precision dx(*),dy(*),dtemp X integer i,incx,incy,ix,iy,m,mp1,n Xc X ddot = 0.0d0 X dtemp = 0.0d0 X if(n.le.0)return X if(incx.eq.1.and.incy.eq.1)go to 20 Xc Xc code for unequal increments or equal increments Xc not equal to 1 Xc X ix = 1 X iy = 1 X if(incx.lt.0)ix = (-n+1)*incx + 1 X if(incy.lt.0)iy = (-n+1)*incy + 1 X do 10 i = 1,n X dtemp = dtemp + dx(ix)*dy(iy) X ix = ix + incx X iy = iy + incy X 10 continue X ddot = dtemp X return Xc Xc code for both increments equal to 1 Xc Xc Xc clean-up loop Xc X 20 m = mod(n,5) X if( m .eq. 0 ) go to 40 X do 30 i = 1,m X dtemp = dtemp + dx(i)*dy(i) X 30 continue X if( n .lt. 5 ) go to 60 X 40 mp1 = m + 1 X do 50 i = mp1,n,5 X dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) + X * dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4) X 50 continue X 60 ddot = dtemp X return X end X SUBROUTINE DGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, X $ BETA, C, LDC ) X* .. Scalar Arguments .. X CHARACTER*1 TRANSA, TRANSB X INTEGER M, N, K, LDA, LDB, LDC X DOUBLE PRECISION ALPHA, BETA X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) X* .. X* X* Purpose X* ======= X* X* DGEMM performs one of the matrix-matrix operations X* X* C := alpha*op( A )*op( B ) + beta*C, X* X* where op( X ) is one of X* X* op( X ) = X or op( X ) = X', X* X* alpha and beta are scalars, and A, B and C are matrices, with op( A ) X* an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. X* X* Parameters X* ========== X* X* TRANSA - CHARACTER*1. X* On entry, TRANSA specifies the form of op( A ) to be used in X* the matrix multiplication as follows: X* X* TRANSA = 'N' or 'n', op( A ) = A. X* X* TRANSA = 'T' or 't', op( A ) = A'. X* X* TRANSA = 'C' or 'c', op( A ) = A'. X* X* Unchanged on exit. X* X* TRANSB - CHARACTER*1. X* On entry, TRANSB specifies the form of op( B ) to be used in X* the matrix multiplication as follows: X* X* TRANSB = 'N' or 'n', op( B ) = B. X* X* TRANSB = 'T' or 't', op( B ) = B'. X* X* TRANSB = 'C' or 'c', op( B ) = B'. X* X* Unchanged on exit. X* X* M - INTEGER. X* On entry, M specifies the number of rows of the matrix X* op( A ) and of the matrix C. M must be at least zero. X* Unchanged on exit. X* X* N - INTEGER. X* On entry, N specifies the number of columns of the matrix X* op( B ) and the number of columns of the matrix C. N must be X* at least zero. X* Unchanged on exit. X* X* K - INTEGER. X* On entry, K specifies the number of columns of the matrix X* op( A ) and the number of rows of the matrix op( B ). K must X* be at least zero. X* Unchanged on exit. X* X* ALPHA - DOUBLE PRECISION. X* On entry, ALPHA specifies the scalar alpha. X* Unchanged on exit. X* X* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is X* k when TRANSA = 'N' or 'n', and is m otherwise. X* Before entry with TRANSA = 'N' or 'n', the leading m by k X* part of the array A must contain the matrix A, otherwise X* the leading k by m part of the array A must contain the X* matrix A. X* Unchanged on exit. X* X* LDA - INTEGER. X* On entry, LDA specifies the first dimension of A as declared X* in the calling (sub) program. When TRANSA = 'N' or 'n' then X* LDA must be at least max( 1, m ), otherwise LDA must be at X* least max( 1, k ). X* Unchanged on exit. X* X* B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is X* n when TRANSB = 'N' or 'n', and is k otherwise. X* Before entry with TRANSB = 'N' or 'n', the leading k by n X* part of the array B must contain the matrix B, otherwise X* the leading n by k part of the array B must contain the X* matrix B. X* Unchanged on exit. X* X* LDB - INTEGER. X* On entry, LDB specifies the first dimension of B as declared X* in the calling (sub) program. When TRANSB = 'N' or 'n' then X* LDB must be at least max( 1, k ), otherwise LDB must be at X* least max( 1, n ). X* Unchanged on exit. X* X* BETA - DOUBLE PRECISION. X* On entry, BETA specifies the scalar beta. When BETA is X* supplied as zero then C need not be set on input. X* Unchanged on exit. X* X* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). X* Before entry, the leading m by n part of the array C must X* contain the matrix C, except when beta is zero, in which X* case C need not be set on entry. X* On exit, the array C is overwritten by the m by n matrix X* ( alpha*op( A )*op( B ) + beta*C ). X* X* LDC - INTEGER. X* On entry, LDC specifies the first dimension of C as declared X* in the calling (sub) program. LDC must be at least X* max( 1, m ). X* Unchanged on exit. X* X* X* Level 3 Blas routine. X* X* -- Written on 8-February-1989. X* Jack Dongarra, Argonne National Laboratory. X* Iain Duff, AERE Harwell. X* Jeremy Du Croz, Numerical Algorithms Group Ltd. X* Sven Hammarling, Numerical Algorithms Group Ltd. X* X* X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. External Subroutines .. X EXTERNAL XERBLA X* .. Intrinsic Functions .. X INTRINSIC MAX X* .. Local Scalars .. X LOGICAL NOTA, NOTB X INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB X DOUBLE PRECISION TEMP X* .. Parameters .. X DOUBLE PRECISION ONE , ZERO X PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) X* .. X* .. Executable Statements .. X* X* Set NOTA and NOTB as true if A and B respectively are not X* transposed and set NROWA, NCOLA and NROWB as the number of rows X* and columns of A and the number of rows of B respectively. X* X NOTA = LSAME( TRANSA, 'N' ) X NOTB = LSAME( TRANSB, 'N' ) X IF( NOTA )THEN X NROWA = M X NCOLA = K X ELSE X NROWA = K X NCOLA = M X END IF X IF( NOTB )THEN X NROWB = K X ELSE X NROWB = N X END IF X* X* Test the input parameters. X* X INFO = 0 X IF( ( .NOT.NOTA ).AND. X $ ( .NOT.LSAME( TRANSA, 'C' ) ).AND. X $ ( .NOT.LSAME( TRANSA, 'T' ) ) )THEN X INFO = 1 X ELSE IF( ( .NOT.NOTB ).AND. X $ ( .NOT.LSAME( TRANSB, 'C' ) ).AND. X $ ( .NOT.LSAME( TRANSB, 'T' ) ) )THEN X INFO = 2 X ELSE IF( M .LT.0 )THEN X INFO = 3 X ELSE IF( N .LT.0 )THEN X INFO = 4 X ELSE IF( K .LT.0 )THEN X INFO = 5 X ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN X INFO = 8 X ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN X INFO = 10 X ELSE IF( LDC.LT.MAX( 1, M ) )THEN X INFO = 13 X END IF X IF( INFO.NE.0 )THEN X CALL XERBLA( 'DGEMM ', INFO ) X RETURN X END IF X* X* Quick return if possible. X* X IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. X $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) X $ RETURN X* X* And if alpha.eq.zero. X* X IF( ALPHA.EQ.ZERO )THEN X IF( BETA.EQ.ZERO )THEN X DO 20, J = 1, N X DO 10, I = 1, M X C( I, J ) = ZERO X 10 CONTINUE X 20 CONTINUE X ELSE X DO 40, J = 1, N X DO 30, I = 1, M X C( I, J ) = BETA*C( I, J ) X 30 CONTINUE X 40 CONTINUE X END IF X RETURN X END IF X* X* Start the operations. X* X IF( NOTB )THEN X IF( NOTA )THEN X* X* Form C := alpha*A*B + beta*C. X* X DO 90, J = 1, N X IF( BETA.EQ.ZERO )THEN X DO 50, I = 1, M X C( I, J ) = ZERO X 50 CONTINUE X ELSE IF( BETA.NE.ONE )THEN X DO 60, I = 1, M X C( I, J ) = BETA*C( I, J ) X 60 CONTINUE X END IF X DO 80, L = 1, K X IF( B( L, J ).NE.ZERO )THEN X TEMP = ALPHA*B( L, J ) X DO 70, I = 1, M X C( I, J ) = C( I, J ) + TEMP*A( I, L ) X 70 CONTINUE X END IF X 80 CONTINUE X 90 CONTINUE X ELSE X* X* Form C := alpha*A'*B + beta*C X* X DO 120, J = 1, N X DO 110, I = 1, M X TEMP = ZERO X DO 100, L = 1, K X TEMP = TEMP + A( L, I )*B( L, J ) X 100 CONTINUE X IF( BETA.EQ.ZERO )THEN X C( I, J ) = ALPHA*TEMP X ELSE X C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) X END IF X 110 CONTINUE X 120 CONTINUE X END IF X ELSE X IF( NOTA )THEN X* X* Form C := alpha*A*B' + beta*C X* X DO 170, J = 1, N X IF( BETA.EQ.ZERO )THEN X DO 130, I = 1, M X C( I, J ) = ZERO X 130 CONTINUE X ELSE IF( BETA.NE.ONE )THEN X DO 140, I = 1, M X C( I, J ) = BETA*C( I, J ) X 140 CONTINUE X END IF X DO 160, L = 1, K X IF( B( J, L ).NE.ZERO )THEN X TEMP = ALPHA*B( J, L ) X DO 150, I = 1, M X C( I, J ) = C( I, J ) + TEMP*A( I, L ) X 150 CONTINUE X END IF X 160 CONTINUE X 170 CONTINUE X ELSE X* X* Form C := alpha*A'*B' + beta*C X* X DO 200, J = 1, N X DO 190, I = 1, M X TEMP = ZERO X DO 180, L = 1, K X TEMP = TEMP + A( L, I )*B( J, L ) X 180 CONTINUE X IF( BETA.EQ.ZERO )THEN X C( I, J ) = ALPHA*TEMP X ELSE X C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) X END IF X 190 CONTINUE X 200 CONTINUE X END IF X END IF X* X RETURN X* X* End of DGEMM . X* X END X SUBROUTINE DGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, X $ BETA, Y, INCY ) X* .. Scalar Arguments .. X DOUBLE PRECISION ALPHA, BETA X INTEGER INCX, INCY, LDA, M, N X CHARACTER*1 TRANS X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) X* .. X* X* Purpose X* ======= X* X* DGEMV performs one of the matrix-vector operations X* X* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, X* X* where alpha and beta are scalars, x and y are vectors and A is an X* m by n matrix. X* X* Parameters X* ========== X* X* TRANS - CHARACTER*1. X* On entry, TRANS specifies the operation to be performed as X* follows: X* X* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. X* X* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. X* X* TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. X* X* Unchanged on exit. X* X* M - INTEGER. X* On entry, M specifies the number of rows of the matrix A. X* M must be at least zero. X* Unchanged on exit. X* X* N - INTEGER. X* On entry, N specifies the number of columns of the matrix A. X* N must be at least zero. X* Unchanged on exit. X* X* ALPHA - DOUBLE PRECISION. X* On entry, ALPHA specifies the scalar alpha. X* Unchanged on exit. X* X* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). X* Before entry, the leading m by n part of the array A must X* contain the matrix of coefficients. X* Unchanged on exit. X* X* LDA - INTEGER. X* On entry, LDA specifies the first dimension of A as declared X* in the calling (sub) program. LDA must be at least X* max( 1, m ). X* Unchanged on exit. X* X* X - DOUBLE PRECISION array of DIMENSION at least X* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' X* and at least X* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. X* Before entry, the incremented array X must contain the X* vector x. X* Unchanged on exit. X* X* INCX - INTEGER. X* On entry, INCX specifies the increment for the elements of X* X. INCX must not be zero. X* Unchanged on exit. X* X* BETA - DOUBLE PRECISION. X* On entry, BETA specifies the scalar beta. When BETA is X* supplied as zero then Y need not be set on input. X* Unchanged on exit. X* X* Y - DOUBLE PRECISION array of DIMENSION at least X* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' X* and at least X* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. X* Before entry with BETA non-zero, the incremented array Y X* must contain the vector y. On exit, Y is overwritten by the X* updated vector y. X* X* INCY - INTEGER. X* On entry, INCY specifies the increment for the elements of X* Y. INCY must not be zero. X* Unchanged on exit. X* X* X* Level 2 Blas routine. X* X* -- Written on 22-October-1986. X* Jack Dongarra, Argonne National Lab. X* Jeremy Du Croz, Nag Central Office. X* Sven Hammarling, Nag Central Office. X* Richard Hanson, Sandia National Labs. X* X* X* .. Parameters .. X DOUBLE PRECISION ONE , ZERO X PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) X* .. Local Scalars .. X DOUBLE PRECISION TEMP X INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. External Subroutines .. X EXTERNAL XERBLA X* .. Intrinsic Functions .. X INTRINSIC MAX X* .. X* .. Executable Statements .. X* X* Test the input parameters. X* X INFO = 0 X IF ( .NOT.LSAME( TRANS, 'N' ).AND. X $ .NOT.LSAME( TRANS, 'T' ).AND. X $ .NOT.LSAME( TRANS, 'C' ) )THEN X INFO = 1 X ELSE IF( M.LT.0 )THEN X INFO = 2 X ELSE IF( N.LT.0 )THEN X INFO = 3 X ELSE IF( LDA.LT.MAX( 1, M ) )THEN X INFO = 6 X ELSE IF( INCX.EQ.0 )THEN X INFO = 8 X ELSE IF( INCY.EQ.0 )THEN X INFO = 11 X END IF X IF( INFO.NE.0 )THEN X CALL XERBLA( 'DGEMV ', INFO ) X RETURN X END IF X* X* Quick return if possible. X* X IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. X $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) X $ RETURN X* X* Set LENX and LENY, the lengths of the vectors x and y, and set X* up the start points in X and Y. X* X IF( LSAME( TRANS, 'N' ) )THEN X LENX = N X LENY = M X ELSE X LENX = M X LENY = N X END IF X IF( INCX.GT.0 )THEN X KX = 1 X ELSE X KX = 1 - ( LENX - 1 )*INCX X END IF X IF( INCY.GT.0 )THEN X KY = 1 X ELSE X KY = 1 - ( LENY - 1 )*INCY X END IF X* X* Start the operations. In this version the elements of A are X* accessed sequentially with one pass through A. X* X* First form y := beta*y. X* X IF( BETA.NE.ONE )THEN X IF( INCY.EQ.1 )THEN X IF( BETA.EQ.ZERO )THEN X DO 10, I = 1, LENY X Y( I ) = ZERO X 10 CONTINUE X ELSE X DO 20, I = 1, LENY X Y( I ) = BETA*Y( I ) X 20 CONTINUE X END IF X ELSE X IY = KY X IF( BETA.EQ.ZERO )THEN X DO 30, I = 1, LENY X Y( IY ) = ZERO X IY = IY + INCY X 30 CONTINUE X ELSE X DO 40, I = 1, LENY X Y( IY ) = BETA*Y( IY ) X IY = IY + INCY X 40 CONTINUE X END IF X END IF X END IF X IF( ALPHA.EQ.ZERO ) X $ RETURN X IF( LSAME( TRANS, 'N' ) )THEN X* X* Form y := alpha*A*x + y. X* X JX = KX X IF( INCY.EQ.1 )THEN X DO 60, J = 1, N X IF( X( JX ).NE.ZERO )THEN X TEMP = ALPHA*X( JX ) X DO 50, I = 1, M X Y( I ) = Y( I ) + TEMP*A( I, J ) X 50 CONTINUE X END IF X JX = JX + INCX X 60 CONTINUE X ELSE X DO 80, J = 1, N X IF( X( JX ).NE.ZERO )THEN X TEMP = ALPHA*X( JX ) X IY = KY X DO 70, I = 1, M X Y( IY ) = Y( IY ) + TEMP*A( I, J ) X IY = IY + INCY X 70 CONTINUE X END IF X JX = JX + INCX X 80 CONTINUE X END IF X ELSE X* X* Form y := alpha*A'*x + y. X* X JY = KY X IF( INCX.EQ.1 )THEN X DO 100, J = 1, N X TEMP = ZERO X DO 90, I = 1, M X TEMP = TEMP + A( I, J )*X( I ) X 90 CONTINUE X Y( JY ) = Y( JY ) + ALPHA*TEMP X JY = JY + INCY X 100 CONTINUE X ELSE X DO 120, J = 1, N X TEMP = ZERO X IX = KX X DO 110, I = 1, M X TEMP = TEMP + A( I, J )*X( IX ) X IX = IX + INCX X 110 CONTINUE X Y( JY ) = Y( JY ) + ALPHA*TEMP X JY = JY + INCY X 120 CONTINUE X END IF X END IF X* X RETURN X* X* End of DGEMV . X* X END X* X subroutine dscal(n,da,dx,incx) Xc Xc scales a vector by a constant. Xc uses unrolled loops for increment equal to one. Xc jack dongarra, linpack, 3/11/78. Xc modified 3/93 to return if incx .le. 0. Xc modified 12/3/93, array(1) declarations changed to array(*) Xc X double precision da,dx(*) X integer i,incx,m,mp1,n,nincx Xc X if( n.le.0 .or. incx.le.0 )return X if(incx.eq.1)go to 20 Xc Xc code for increment not equal to 1 Xc X nincx = n*incx X do 10 i = 1,nincx,incx X dx(i) = da*dx(i) X 10 continue X return Xc Xc code for increment equal to 1 Xc Xc Xc clean-up loop Xc X 20 m = mod(n,5) X if( m .eq. 0 ) go to 40 X do 30 i = 1,m X dx(i) = da*dx(i) X 30 continue X if( n .lt. 5 ) return X 40 mp1 = m + 1 X do 50 i = mp1,n,5 X dx(i) = da*dx(i) X dx(i + 1) = da*dx(i + 1) X dx(i + 2) = da*dx(i + 2) X dx(i + 3) = da*dx(i + 3) X dx(i + 4) = da*dx(i + 4) X 50 continue X return X end X subroutine dswap (n,dx,incx,dy,incy) Xc Xc interchanges two vectors. Xc uses unrolled loops for increments equal one. Xc jack dongarra, linpack, 3/11/78. Xc modified 12/3/93, array(1) declarations changed to array(*) Xc X double precision dx(*),dy(*),dtemp X integer i,incx,incy,ix,iy,m,mp1,n Xc X if(n.le.0)return X if(incx.eq.1.and.incy.eq.1)go to 20 Xc Xc code for unequal increments or equal increments not equal Xc to 1 Xc X ix = 1 X iy = 1 X if(incx.lt.0)ix = (-n+1)*incx + 1 X if(incy.lt.0)iy = (-n+1)*incy + 1 X do 10 i = 1,n X dtemp = dx(ix) X dx(ix) = dy(iy) X dy(iy) = dtemp X ix = ix + incx X iy = iy + incy X 10 continue X return Xc Xc code for both increments equal to 1 Xc Xc Xc clean-up loop Xc X 20 m = mod(n,3) X if( m .eq. 0 ) go to 40 X do 30 i = 1,m X dtemp = dx(i) X dx(i) = dy(i) X dy(i) = dtemp X 30 continue X if( n .lt. 3 ) return X 40 mp1 = m + 1 X do 50 i = mp1,n,3 X dtemp = dx(i) X dx(i) = dy(i) X dy(i) = dtemp X dtemp = dx(i + 1) X dx(i + 1) = dy(i + 1) X dy(i + 1) = dtemp X dtemp = dx(i + 2) X dx(i + 2) = dy(i + 2) X dy(i + 2) = dtemp X 50 continue X return X end X* X subroutine zaxpy(n,za,zx,incx,zy,incy) Xc Xc constant times a vector plus a vector. Xc jack dongarra, 3/11/78. Xc modified 12/3/93, array(1) declarations changed to array(*) Xc X double complex zx(*),zy(*),za X integer i,incx,incy,ix,iy,n X double precision dcabs1 X if(n.le.0)return X if (dcabs1(za) .eq. 0.0d0) return X if (incx.eq.1.and.incy.eq.1)go to 20 Xc Xc code for unequal increments or equal increments Xc not equal to 1 Xc X ix = 1 X iy = 1 X if(incx.lt.0)ix = (-n+1)*incx + 1 X if(incy.lt.0)iy = (-n+1)*incy + 1 X do 10 i = 1,n X zy(iy) = zy(iy) + za*zx(ix) X ix = ix + incx X iy = iy + incy X 10 continue X return X Xc code for both increments equal to 1 Xc X 20 do 30 i = 1,n X zy(i) = zy(i) + za*zx(i) X 30 continue X return X end X subroutine zswap (n,zx,incx,zy,incy) Xc Xc interchanges two vectors. Xc jack dongarra, 3/11/78. Xc modified 12/3/93, array(1) declarations changed to array(*) Xc X double complex zx(*),zy(*),ztemp X integer i,incx,incy,ix,iy,n Xc X if(n.le.0)return X if(incx.eq.1.and.incy.eq.1)go to 20 Xc Xc code for unequal increments or equal increments not equal Xc to 1 Xc X ix = 1 X iy = 1 X if(incx.lt.0)ix = (-n+1)*incx + 1 X if(incy.lt.0)iy = (-n+1)*incy + 1 X do 10 i = 1,n X ztemp = zx(ix) X zx(ix) = zy(iy) X zy(iy) = ztemp X ix = ix + incx X iy = iy + incy X 10 continue X return Xc Xc code for both increments equal to 1 X 20 do 30 i = 1,n X ztemp = zx(i) X zx(i) = zy(i) X zy(i) = ztemp X 30 continue X return X end X* X DOUBLE PRECISION FUNCTION DNRM2 ( N, X, INCX ) X* .. Scalar Arguments .. X INTEGER INCX, N X* .. Array Arguments .. X DOUBLE PRECISION X( * ) X* .. X* X* DNRM2 returns the euclidean norm of a vector via the function X* name, so that X* X* DNRM2 := sqrt( x'*x ) X* X* X* X* -- This version written on 25-October-1982. X* Modified on 14-October-1993 to inline the call to DLASSQ. X* Sven Hammarling, Nag Ltd. X* X* X* .. Parameters .. X DOUBLE PRECISION ONE , ZERO X PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) X* .. Local Scalars .. X INTEGER IX X DOUBLE PRECISION ABSXI, NORM, SCALE, SSQ X* .. Intrinsic Functions .. X INTRINSIC ABS, SQRT X* .. X* .. Executable Statements .. X IF( N.LT.1 .OR. INCX.LT.1 )THEN X NORM = ZERO X ELSE IF( N.EQ.1 )THEN X NORM = ABS( X( 1 ) ) X ELSE X SCALE = ZERO X SSQ = ONE X* The following loop is equivalent to this call to the LAPACK X* auxiliary routine: X* CALL DLASSQ( N, X, INCX, SCALE, SSQ ) X* X DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX X IF( X( IX ).NE.ZERO )THEN X ABSXI = ABS( X( IX ) ) X IF( SCALE.LT.ABSXI )THEN X SSQ = ONE + SSQ*( SCALE/ABSXI )**2 X SCALE = ABSXI X ELSE X SSQ = SSQ + ( ABSXI/SCALE )**2 X END IF X END IF X 10 CONTINUE X NORM = SCALE * SQRT( SSQ ) X END IF X* X DNRM2 = NORM X RETURN X* X* End of DNRM2. X* X END X* X double precision function dcabs1(z) X double complex z,zz X double precision t(2) X equivalence (zz,t(1)) X zz = z X dcabs1 = dabs(t(1)) + dabs(t(2)) X return X end X* X integer function idamax(n,dx,incx) Xc Xc finds the index of element having max. absolute value. Xc jack dongarra, linpack, 3/11/78. Xc modified 3/93 to return if incx .le. 0. Xc modified 12/3/93, array(1) declarations changed to array(*) Xc X double precision dx(*),dmax X integer i,incx,ix,n Xc X idamax = 0 X if( n.lt.1 .or. incx.le.0 ) return X idamax = 1 X if(n.eq.1)return X if(incx.eq.1)go to 20 Xc Xc code for increment not equal to 1 Xc X ix = 1 X dmax = dabs(dx(1)) X ix = ix + incx X do 10 i = 2,n X if(dabs(dx(ix)).le.dmax) go to 5 X idamax = i X dmax = dabs(dx(ix)) X 5 ix = ix + incx X 10 continue X return Xc Xc code for increment equal to 1 Xc X 20 dmax = dabs(dx(1)) X do 30 i = 2,n X if(dabs(dx(i)).le.dmax) go to 30 X idamax = i X dmax = dabs(dx(i)) X 30 continue X return X end X* X SUBROUTINE DSYR2K( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, X $ BETA, C, LDC ) X* .. Scalar Arguments .. X CHARACTER*1 UPLO, TRANS X INTEGER N, K, LDA, LDB, LDC X DOUBLE PRECISION ALPHA, BETA X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) X* .. X* X* Purpose X* ======= X* X* DSYR2K performs one of the symmetric rank 2k operations X* X* C := alpha*A*B' + alpha*B*A' + beta*C, X* X* or X* X* C := alpha*A'*B + alpha*B'*A + beta*C, X* X* where alpha and beta are scalars, C is an n by n symmetric matrix X* and A and B are n by k matrices in the first case and k by n X* matrices in the second case. X* X* Parameters X* ========== X* X* UPLO - CHARACTER*1. X* On entry, UPLO specifies whether the upper or lower X* triangular part of the array C is to be referenced as X* follows: X* X* UPLO = 'U' or 'u' Only the upper triangular part of C X* is to be referenced. X* X* UPLO = 'L' or 'l' Only the lower triangular part of C X* is to be referenced. X* X* Unchanged on exit. X* X* TRANS - CHARACTER*1. X* On entry, TRANS specifies the operation to be performed as X* follows: X* X* TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + X* beta*C. X* X* TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A + X* beta*C. X* X* TRANS = 'C' or 'c' C := alpha*A'*B + alpha*B'*A + X* beta*C. X* X* Unchanged on exit. X* X* N - INTEGER. X* On entry, N specifies the order of the matrix C. N must be X* at least zero. X* Unchanged on exit. X* X* K - INTEGER. X* On entry with TRANS = 'N' or 'n', K specifies the number X* of columns of the matrices A and B, and on entry with X* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number X* of rows of the matrices A and B. K must be at least zero. X* Unchanged on exit. X* X* ALPHA - DOUBLE PRECISION. X* On entry, ALPHA specifies the scalar alpha. X* Unchanged on exit. X* X* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is X* k when TRANS = 'N' or 'n', and is n otherwise. X* Before entry with TRANS = 'N' or 'n', the leading n by k X* part of the array A must contain the matrix A, otherwise X* the leading k by n part of the array A must contain the X* matrix A. X* Unchanged on exit. X* X* LDA - INTEGER. X* On entry, LDA specifies the first dimension of A as declared X* in the calling (sub) program. When TRANS = 'N' or 'n' X* then LDA must be at least max( 1, n ), otherwise LDA must X* be at least max( 1, k ). X* Unchanged on exit. X* X* B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is X* k when TRANS = 'N' or 'n', and is n otherwise. X* Before entry with TRANS = 'N' or 'n', the leading n by k X* part of the array B must contain the matrix B, otherwise X* the leading k by n part of the array B must contain the X* matrix B. X* Unchanged on exit. X* X* LDB - INTEGER. X* On entry, LDB specifies the first dimension of B as declared X* in the calling (sub) program. When TRANS = 'N' or 'n' X* then LDB must be at least max( 1, n ), otherwise LDB must X* be at least max( 1, k ). X* Unchanged on exit. X* X* BETA - DOUBLE PRECISION. X* On entry, BETA specifies the scalar beta. X* Unchanged on exit. X* X* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). X* Before entry with UPLO = 'U' or 'u', the leading n by n X* upper triangular part of the array C must contain the upper X* triangular part of the symmetric matrix and the strictly X* lower triangular part of C is not referenced. On exit, the X* upper triangular part of the array C is overwritten by the X* upper triangular part of the updated matrix. X* Before entry with UPLO = 'L' or 'l', the leading n by n X* lower triangular part of the array C must contain the lower X* triangular part of the symmetric matrix and the strictly X* upper triangular part of C is not referenced. On exit, the X* lower triangular part of the array C is overwritten by the X* lower triangular part of the updated matrix. X* X* LDC - INTEGER. X* On entry, LDC specifies the first dimension of C as declared X* in the calling (sub) program. LDC must be at least X* max( 1, n ). X* Unchanged on exit. X* X* X* Level 3 Blas routine. X* X* X* -- Written on 8-February-1989. X* Jack Dongarra, Argonne National Laboratory. X* Iain Duff, AERE Harwell. X* Jeremy Du Croz, Numerical Algorithms Group Ltd. X* Sven Hammarling, Numerical Algorithms Group Ltd. X* X* X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. External Subroutines .. X EXTERNAL XERBLA X* .. Intrinsic Functions .. X INTRINSIC MAX X* .. Local Scalars .. X LOGICAL UPPER X INTEGER I, INFO, J, L, NROWA X DOUBLE PRECISION TEMP1, TEMP2 X* .. Parameters .. X DOUBLE PRECISION ONE , ZERO X PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) X* .. X* .. Executable Statements .. X* X* Test the input parameters. X* X IF( LSAME( TRANS, 'N' ) )THEN X NROWA = N X ELSE X NROWA = K X END IF X UPPER = LSAME( UPLO, 'U' ) X* X INFO = 0 X IF( ( .NOT.UPPER ).AND. X $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN X INFO = 1 X ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. X $ ( .NOT.LSAME( TRANS, 'T' ) ).AND. X $ ( .NOT.LSAME( TRANS, 'C' ) ) )THEN X INFO = 2 X ELSE IF( N .LT.0 )THEN X INFO = 3 X ELSE IF( K .LT.0 )THEN X INFO = 4 X ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN X INFO = 7 X ELSE IF( LDB.LT.MAX( 1, NROWA ) )THEN X INFO = 9 X ELSE IF( LDC.LT.MAX( 1, N ) )THEN X INFO = 12 X END IF X IF( INFO.NE.0 )THEN X CALL XERBLA( 'DSYR2K', INFO ) X RETURN X END IF X* X* Quick return if possible. X* X IF( ( N.EQ.0 ).OR. X $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) X $ RETURN X* X* And when alpha.eq.zero. X* X IF( ALPHA.EQ.ZERO )THEN X IF( UPPER )THEN X IF( BETA.EQ.ZERO )THEN X DO 20, J = 1, N X DO 10, I = 1, J X C( I, J ) = ZERO X 10 CONTINUE X 20 CONTINUE X ELSE X DO 40, J = 1, N X DO 30, I = 1, J X C( I, J ) = BETA*C( I, J ) X 30 CONTINUE X 40 CONTINUE X END IF X ELSE X IF( BETA.EQ.ZERO )THEN X DO 60, J = 1, N X DO 50, I = J, N X C( I, J ) = ZERO X 50 CONTINUE X 60 CONTINUE X ELSE X DO 80, J = 1, N X DO 70, I = J, N X C( I, J ) = BETA*C( I, J ) X 70 CONTINUE X 80 CONTINUE X END IF X END IF X RETURN X END IF X* X* Start the operations. X* X IF( LSAME( TRANS, 'N' ) )THEN X* X* Form C := alpha*A*B' + alpha*B*A' + C. X* X IF( UPPER )THEN X DO 130, J = 1, N X IF( BETA.EQ.ZERO )THEN X DO 90, I = 1, J X C( I, J ) = ZERO X 90 CONTINUE X ELSE IF( BETA.NE.ONE )THEN X DO 100, I = 1, J X C( I, J ) = BETA*C( I, J ) X 100 CONTINUE X END IF X DO 120, L = 1, K X IF( ( A( J, L ).NE.ZERO ).OR. X $ ( B( J, L ).NE.ZERO ) )THEN X TEMP1 = ALPHA*B( J, L ) X TEMP2 = ALPHA*A( J, L ) X DO 110, I = 1, J X C( I, J ) = C( I, J ) + X $ A( I, L )*TEMP1 + B( I, L )*TEMP2 X 110 CONTINUE X END IF X 120 CONTINUE X 130 CONTINUE X ELSE X DO 180, J = 1, N X IF( BETA.EQ.ZERO )THEN X DO 140, I = J, N X C( I, J ) = ZERO X 140 CONTINUE X ELSE IF( BETA.NE.ONE )THEN X DO 150, I = J, N X C( I, J ) = BETA*C( I, J ) X 150 CONTINUE X END IF X DO 170, L = 1, K X IF( ( A( J, L ).NE.ZERO ).OR. X $ ( B( J, L ).NE.ZERO ) )THEN X TEMP1 = ALPHA*B( J, L ) X TEMP2 = ALPHA*A( J, L ) X DO 160, I = J, N X C( I, J ) = C( I, J ) + X $ A( I, L )*TEMP1 + B( I, L )*TEMP2 X 160 CONTINUE X END IF X 170 CONTINUE X 180 CONTINUE X END IF X ELSE X* X* Form C := alpha*A'*B + alpha*B'*A + C. X* X IF( UPPER )THEN X DO 210, J = 1, N X DO 200, I = 1, J X TEMP1 = ZERO X TEMP2 = ZERO X DO 190, L = 1, K X TEMP1 = TEMP1 + A( L, I )*B( L, J ) X TEMP2 = TEMP2 + B( L, I )*A( L, J ) X 190 CONTINUE X IF( BETA.EQ.ZERO )THEN X C( I, J ) = ALPHA*TEMP1 + ALPHA*TEMP2 X ELSE X C( I, J ) = BETA *C( I, J ) + X $ ALPHA*TEMP1 + ALPHA*TEMP2 X END IF X 200 CONTINUE X 210 CONTINUE X ELSE X DO 240, J = 1, N X DO 230, I = J, N X TEMP1 = ZERO X TEMP2 = ZERO X DO 220, L = 1, K X TEMP1 = TEMP1 + A( L, I )*B( L, J ) X TEMP2 = TEMP2 + B( L, I )*A( L, J ) X 220 CONTINUE X IF( BETA.EQ.ZERO )THEN X C( I, J ) = ALPHA*TEMP1 + ALPHA*TEMP2 X ELSE X C( I, J ) = BETA *C( I, J ) + X $ ALPHA*TEMP1 + ALPHA*TEMP2 X END IF X 230 CONTINUE X 240 CONTINUE X END IF X END IF X* X RETURN X* X* End of DSYR2K. X* X END X* X SUBROUTINE DTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, X $ B, LDB ) X* .. Scalar Arguments .. X CHARACTER*1 SIDE, UPLO, TRANSA, DIAG X INTEGER M, N, LDA, LDB X DOUBLE PRECISION ALPHA X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), B( LDB, * ) X* .. X* X* Purpose X* ======= X* X* DTRSM solves one of the matrix equations X* X* op( A )*X = alpha*B, or X*op( A ) = alpha*B, X* X* where alpha is a scalar, X and B are m by n matrices, A is a unit, or X* non-unit, upper or lower triangular matrix and op( A ) is one of X* X* op( A ) = A or op( A ) = A'. X* X* The matrix X is overwritten on B. X* X* Parameters X* ========== X* X* SIDE - CHARACTER*1. X* On entry, SIDE specifies whether op( A ) appears on the left X* or right of X as follows: X* X* SIDE = 'L' or 'l' op( A )*X = alpha*B. X* X* SIDE = 'R' or 'r' X*op( A ) = alpha*B. X* X* Unchanged on exit. X* X* UPLO - CHARACTER*1. X* On entry, UPLO specifies whether the matrix A is an upper or X* lower triangular matrix as follows: X* X* UPLO = 'U' or 'u' A is an upper triangular matrix. X* X* UPLO = 'L' or 'l' A is a lower triangular matrix. X* X* Unchanged on exit. X* X* TRANSA - CHARACTER*1. X* On entry, TRANSA specifies the form of op( A ) to be used in X* the matrix multiplication as follows: X* X* TRANSA = 'N' or 'n' op( A ) = A. X* X* TRANSA = 'T' or 't' op( A ) = A'. X* X* TRANSA = 'C' or 'c' op( A ) = A'. X* X* Unchanged on exit. X* X* DIAG - CHARACTER*1. X* On entry, DIAG specifies whether or not A is unit triangular X* as follows: X* X* DIAG = 'U' or 'u' A is assumed to be unit triangular. X* X* DIAG = 'N' or 'n' A is not assumed to be unit X* triangular. X* X* Unchanged on exit. X* X* M - INTEGER. X* On entry, M specifies the number of rows of B. M must be at X* least zero. X* Unchanged on exit. X* X* N - INTEGER. X* On entry, N specifies the number of columns of B. N must be X* at least zero. X* Unchanged on exit. X* X* ALPHA - DOUBLE PRECISION. X* On entry, ALPHA specifies the scalar alpha. When alpha is X* zero then A is not referenced and B need not be set before X* entry. X* Unchanged on exit. X* X* A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m X* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. X* Before entry with UPLO = 'U' or 'u', the leading k by k X* upper triangular part of the array A must contain the upper X* triangular matrix and the strictly lower triangular part of X* A is not referenced. X* Before entry with UPLO = 'L' or 'l', the leading k by k X* lower triangular part of the array A must contain the lower X* triangular matrix and the strictly upper triangular part of X* A is not referenced. X* Note that when DIAG = 'U' or 'u', the diagonal elements of X* A are not referenced either, but are assumed to be unity. X* Unchanged on exit. X* X* LDA - INTEGER. X* On entry, LDA specifies the first dimension of A as declared X* in the calling (sub) program. When SIDE = 'L' or 'l' then X* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' X* then LDA must be at least max( 1, n ). X* Unchanged on exit. X* X* B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). X* Before entry, the leading m by n part of the array B must X* contain the right-hand side matrix B, and on exit is X* overwritten by the solution matrix X. X* X* LDB - INTEGER. X* On entry, LDB specifies the first dimension of B as declared X* in the calling (sub) program. LDB must be at least X* max( 1, m ). X* Unchanged on exit. X* X* X* Level 3 Blas routine. X* X* X* -- Written on 8-February-1989. X* Jack Dongarra, Argonne National Laboratory. X* Iain Duff, AERE Harwell. X* Jeremy Du Croz, Numerical Algorithms Group Ltd. X* Sven Hammarling, Numerical Algorithms Group Ltd. X* X* X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. External Subroutines .. X EXTERNAL XERBLA X* .. Intrinsic Functions .. X INTRINSIC MAX X* .. Local Scalars .. X LOGICAL LSIDE, NOUNIT, UPPER X INTEGER I, INFO, J, K, NROWA X DOUBLE PRECISION TEMP X* .. Parameters .. X DOUBLE PRECISION ONE , ZERO X PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) X* .. X* .. Executable Statements .. X* X* Test the input parameters. X* X LSIDE = LSAME( SIDE , 'L' ) X IF( LSIDE )THEN X NROWA = M X ELSE X NROWA = N X END IF X NOUNIT = LSAME( DIAG , 'N' ) X UPPER = LSAME( UPLO , 'U' ) X* X INFO = 0 X IF( ( .NOT.LSIDE ).AND. X $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN X INFO = 1 X ELSE IF( ( .NOT.UPPER ).AND. X $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN X INFO = 2 X ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. X $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. X $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN X INFO = 3 X ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. X $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN X INFO = 4 X ELSE IF( M .LT.0 )THEN X INFO = 5 X ELSE IF( N .LT.0 )THEN X INFO = 6 X ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN X INFO = 9 X ELSE IF( LDB.LT.MAX( 1, M ) )THEN X INFO = 11 X END IF X IF( INFO.NE.0 )THEN X CALL XERBLA( 'DTRSM ', INFO ) X RETURN X END IF X* X* Quick return if possible. X* X IF( N.EQ.0 ) X $ RETURN X* X* And when alpha.eq.zero. X* X IF( ALPHA.EQ.ZERO )THEN X DO 20, J = 1, N X DO 10, I = 1, M X B( I, J ) = ZERO X 10 CONTINUE X 20 CONTINUE X RETURN X END IF X* X* Start the operations. X* X IF( LSIDE )THEN X IF( LSAME( TRANSA, 'N' ) )THEN X* X* Form B := alpha*inv( A )*B. X* X IF( UPPER )THEN X DO 60, J = 1, N X IF( ALPHA.NE.ONE )THEN X DO 30, I = 1, M X B( I, J ) = ALPHA*B( I, J ) X 30 CONTINUE X END IF X DO 50, K = M, 1, -1 X IF( B( K, J ).NE.ZERO )THEN X IF( NOUNIT ) X $ B( K, J ) = B( K, J )/A( K, K ) X DO 40, I = 1, K - 1 X B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) X 40 CONTINUE X END IF X 50 CONTINUE X 60 CONTINUE X ELSE X DO 100, J = 1, N X IF( ALPHA.NE.ONE )THEN X DO 70, I = 1, M X B( I, J ) = ALPHA*B( I, J ) X 70 CONTINUE X END IF X DO 90 K = 1, M X IF( B( K, J ).NE.ZERO )THEN X IF( NOUNIT ) X $ B( K, J ) = B( K, J )/A( K, K ) X DO 80, I = K + 1, M X B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) X 80 CONTINUE X END IF X 90 CONTINUE X 100 CONTINUE X END IF X ELSE X* X* Form B := alpha*inv( A' )*B. X* X IF( UPPER )THEN X DO 130, J = 1, N X DO 120, I = 1, M X TEMP = ALPHA*B( I, J ) X DO 110, K = 1, I - 1 X TEMP = TEMP - A( K, I )*B( K, J ) X 110 CONTINUE X IF( NOUNIT ) X $ TEMP = TEMP/A( I, I ) X B( I, J ) = TEMP X 120 CONTINUE X 130 CONTINUE X ELSE X DO 160, J = 1, N X DO 150, I = M, 1, -1 X TEMP = ALPHA*B( I, J ) X DO 140, K = I + 1, M X TEMP = TEMP - A( K, I )*B( K, J ) X 140 CONTINUE X IF( NOUNIT ) X $ TEMP = TEMP/A( I, I ) X B( I, J ) = TEMP X 150 CONTINUE X 160 CONTINUE X END IF X END IF X ELSE X IF( LSAME( TRANSA, 'N' ) )THEN X* X* Form B := alpha*B*inv( A ). X* X IF( UPPER )THEN X DO 210, J = 1, N X IF( ALPHA.NE.ONE )THEN X DO 170, I = 1, M X B( I, J ) = ALPHA*B( I, J ) X 170 CONTINUE X END IF X DO 190, K = 1, J - 1 X IF( A( K, J ).NE.ZERO )THEN X DO 180, I = 1, M X B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) X 180 CONTINUE X END IF X 190 CONTINUE X IF( NOUNIT )THEN X TEMP = ONE/A( J, J ) X DO 200, I = 1, M X B( I, J ) = TEMP*B( I, J ) X 200 CONTINUE X END IF X 210 CONTINUE X ELSE X DO 260, J = N, 1, -1 X IF( ALPHA.NE.ONE )THEN X DO 220, I = 1, M X B( I, J ) = ALPHA*B( I, J ) X 220 CONTINUE X END IF X DO 240, K = J + 1, N X IF( A( K, J ).NE.ZERO )THEN X DO 230, I = 1, M X B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) X 230 CONTINUE X END IF X 240 CONTINUE X IF( NOUNIT )THEN X TEMP = ONE/A( J, J ) X DO 250, I = 1, M X B( I, J ) = TEMP*B( I, J ) X 250 CONTINUE X END IF X 260 CONTINUE X END IF X ELSE X* X* Form B := alpha*B*inv( A' ). X* X IF( UPPER )THEN X DO 310, K = N, 1, -1 X IF( NOUNIT )THEN X TEMP = ONE/A( K, K ) X DO 270, I = 1, M X B( I, K ) = TEMP*B( I, K ) X 270 CONTINUE X END IF X DO 290, J = 1, K - 1 X IF( A( J, K ).NE.ZERO )THEN X TEMP = A( J, K ) X DO 280, I = 1, M X B( I, J ) = B( I, J ) - TEMP*B( I, K ) X 280 CONTINUE X END IF X 290 CONTINUE X IF( ALPHA.NE.ONE )THEN X DO 300, I = 1, M X B( I, K ) = ALPHA*B( I, K ) X 300 CONTINUE X END IF X 310 CONTINUE X ELSE X DO 360, K = 1, N X IF( NOUNIT )THEN X TEMP = ONE/A( K, K ) X DO 320, I = 1, M X B( I, K ) = TEMP*B( I, K ) X 320 CONTINUE X END IF X DO 340, J = K + 1, N X IF( A( J, K ).NE.ZERO )THEN X TEMP = A( J, K ) X DO 330, I = 1, M X B( I, J ) = B( I, J ) - TEMP*B( I, K ) X 330 CONTINUE X END IF X 340 CONTINUE X IF( ALPHA.NE.ONE )THEN X DO 350, I = 1, M X B( I, K ) = ALPHA*B( I, K ) X 350 CONTINUE X END IF X 360 CONTINUE X END IF X END IF X END IF X* X RETURN X* X* End of DTRSM . X* X END X* X double precision function dasum(n,dx,incx) Xc Xc takes the sum of the absolute values. Xc jack dongarra, linpack, 3/11/78. Xc modified 3/93 to return if incx .le. 0. Xc modified 12/3/93, array(1) declarations changed to array(*) Xc X double precision dx(*),dtemp X integer i,incx,m,mp1,n,nincx Xc X dasum = 0.0d0 X dtemp = 0.0d0 X if( n.le.0 .or. incx.le.0 )return X if(incx.eq.1)go to 20 Xc Xc code for increment not equal to 1 Xc X nincx = n*incx X do 10 i = 1,nincx,incx X dtemp = dtemp + dabs(dx(i)) X 10 continue X dasum = dtemp X return Xc Xc code for increment equal to 1 Xc Xc Xc clean-up loop Xc X 20 m = mod(n,6) X if( m .eq. 0 ) go to 40 X do 30 i = 1,m X dtemp = dtemp + dabs(dx(i)) X 30 continue X if( n .lt. 6 ) go to 60 X 40 mp1 = m + 1 X do 50 i = mp1,n,6 X dtemp = dtemp + dabs(dx(i)) + dabs(dx(i + 1)) + dabs(dx(i + 2)) X * + dabs(dx(i + 3)) + dabs(dx(i + 4)) + dabs(dx(i + 5)) X 50 continue X 60 dasum = dtemp X return X end X* X SUBROUTINE DGER ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA ) X* .. Scalar Arguments .. X DOUBLE PRECISION ALPHA X INTEGER INCX, INCY, LDA, M, N X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) X* .. X* X* Purpose X* ======= X* X* DGER performs the rank 1 operation X* X* A := alpha*x*y' + A, X* X* where alpha is a scalar, x is an m element vector, y is an n element X* vector and A is an m by n matrix. X* X* Parameters X* ========== X* X* M - INTEGER. X* On entry, M specifies the number of rows of the matrix A. X* M must be at least zero. X* Unchanged on exit. X* X* N - INTEGER. X* On entry, N specifies the number of columns of the matrix A. X* N must be at least zero. X* Unchanged on exit. X* X* ALPHA - DOUBLE PRECISION. X* On entry, ALPHA specifies the scalar alpha. X* Unchanged on exit. X* X* X - DOUBLE PRECISION array of dimension at least X* ( 1 + ( m - 1 )*abs( INCX ) ). X* Before entry, the incremented array X must contain the m X* element vector x. X* Unchanged on exit. X* X* INCX - INTEGER. X* On entry, INCX specifies the increment for the elements of X* X. INCX must not be zero. X* Unchanged on exit. X* X* Y - DOUBLE PRECISION array of dimension at least X* ( 1 + ( n - 1 )*abs( INCY ) ). X* Before entry, the incremented array Y must contain the n X* element vector y. X* Unchanged on exit. X* X* INCY - INTEGER. X* On entry, INCY specifies the increment for the elements of X* Y. INCY must not be zero. X* Unchanged on exit. X* X* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). X* Before entry, the leading m by n part of the array A must X* contain the matrix of coefficients. On exit, A is X* overwritten by the updated matrix. X* X* LDA - INTEGER. X* On entry, LDA specifies the first dimension of A as declared X* in the calling (sub) program. LDA must be at least X* max( 1, m ). X* Unchanged on exit. X* X* X* Level 2 Blas routine. X* X* -- Written on 22-October-1986. X* Jack Dongarra, Argonne National Lab. X* Jeremy Du Croz, Nag Central Office. X* Sven Hammarling, Nag Central Office. X* Richard Hanson, Sandia National Labs. X* X* X* .. Parameters .. X DOUBLE PRECISION ZERO X PARAMETER ( ZERO = 0.0D+0 ) X* .. Local Scalars .. X DOUBLE PRECISION TEMP X INTEGER I, INFO, IX, J, JY, KX X* .. External Subroutines .. X EXTERNAL XERBLA X* .. Intrinsic Functions .. X INTRINSIC MAX X* .. X* .. Executable Statements .. X* X* Test the input parameters. X* X INFO = 0 X IF ( M.LT.0 )THEN X INFO = 1 X ELSE IF( N.LT.0 )THEN X INFO = 2 X ELSE IF( INCX.EQ.0 )THEN X INFO = 5 X ELSE IF( INCY.EQ.0 )THEN X INFO = 7 X ELSE IF( LDA.LT.MAX( 1, M ) )THEN X INFO = 9 X END IF X IF( INFO.NE.0 )THEN X CALL XERBLA( 'DGER ', INFO ) X RETURN X END IF X* X* Quick return if possible. X* X IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) X $ RETURN X* X* Start the operations. In this version the elements of A are X* accessed sequentially with one pass through A. X* X IF( INCY.GT.0 )THEN X JY = 1 X ELSE X JY = 1 - ( N - 1 )*INCY X END IF X IF( INCX.EQ.1 )THEN X DO 20, J = 1, N X IF( Y( JY ).NE.ZERO )THEN X TEMP = ALPHA*Y( JY ) X DO 10, I = 1, M X A( I, J ) = A( I, J ) + X( I )*TEMP X 10 CONTINUE X END IF X JY = JY + INCY X 20 CONTINUE X ELSE X IF( INCX.GT.0 )THEN X KX = 1 X ELSE X KX = 1 - ( M - 1 )*INCX X END IF X DO 40, J = 1, N X IF( Y( JY ).NE.ZERO )THEN X TEMP = ALPHA*Y( JY ) X IX = KX X DO 30, I = 1, M X A( I, J ) = A( I, J ) + X( IX )*TEMP X IX = IX + INCX X 30 CONTINUE X END IF X JY = JY + INCY X 40 CONTINUE X END IF X* X RETURN X* X* End of DGER . X* X END X* X SUBROUTINE DTRMV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) X* .. Scalar Arguments .. X INTEGER INCX, LDA, N X CHARACTER*1 DIAG, TRANS, UPLO X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), X( * ) X* .. X* X* Purpose X* ======= X* X* DTRMV performs one of the matrix-vector operations X* X* x := A*x, or x := A'*x, X* X* where x is an n element vector and A is an n by n unit, or non-unit, X* upper or lower triangular matrix. X* X* Parameters X* ========== X* X* UPLO - CHARACTER*1. X* On entry, UPLO specifies whether the matrix is an upper or X* lower triangular matrix as follows: X* X* UPLO = 'U' or 'u' A is an upper triangular matrix. X* X* UPLO = 'L' or 'l' A is a lower triangular matrix. X* X* Unchanged on exit. X* X* TRANS - CHARACTER*1. X* On entry, TRANS specifies the operation to be performed as X* follows: X* X* TRANS = 'N' or 'n' x := A*x. X* X* TRANS = 'T' or 't' x := A'*x. X* X* TRANS = 'C' or 'c' x := A'*x. X* X* Unchanged on exit. X* X* DIAG - CHARACTER*1. X* On entry, DIAG specifies whether or not A is unit X* triangular as follows: X* X* DIAG = 'U' or 'u' A is assumed to be unit triangular. X* X* DIAG = 'N' or 'n' A is not assumed to be unit X* triangular. X* X* Unchanged on exit. X* X* N - INTEGER. X* On entry, N specifies the order of the matrix A. X* N must be at least zero. X* Unchanged on exit. X* X* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). X* Before entry with UPLO = 'U' or 'u', the leading n by n X* upper triangular part of the array A must contain the upper X* triangular matrix and the strictly lower triangular part of X* A is not referenced. X* Before entry with UPLO = 'L' or 'l', the leading n by n X* lower triangular part of the array A must contain the lower X* triangular matrix and the strictly upper triangular part of X* A is not referenced. X* Note that when DIAG = 'U' or 'u', the diagonal elements of X* A are not referenced either, but are assumed to be unity. X* Unchanged on exit. X* X* LDA - INTEGER. X* On entry, LDA specifies the first dimension of A as declared X* in the calling (sub) program. LDA must be at least X* max( 1, n ). X* Unchanged on exit. X* X* X - DOUBLE PRECISION array of dimension at least X* ( 1 + ( n - 1 )*abs( INCX ) ). X* Before entry, the incremented array X must contain the n X* element vector x. On exit, X is overwritten with the X* tranformed vector x. X* X* INCX - INTEGER. X* On entry, INCX specifies the increment for the elements of X* X. INCX must not be zero. X* Unchanged on exit. X* X* X* Level 2 Blas routine. X* X* -- Written on 22-October-1986. X* Jack Dongarra, Argonne National Lab. X* Jeremy Du Croz, Nag Central Office. X* Sven Hammarling, Nag Central Office. X* Richard Hanson, Sandia National Labs. X* X* X* .. Parameters .. X DOUBLE PRECISION ZERO X PARAMETER ( ZERO = 0.0D+0 ) X* .. Local Scalars .. X DOUBLE PRECISION TEMP X INTEGER I, INFO, IX, J, JX, KX X LOGICAL NOUNIT X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. External Subroutines .. X EXTERNAL XERBLA X* .. Intrinsic Functions .. X INTRINSIC MAX X* .. X* .. Executable Statements .. X* X* Test the input parameters. X* X INFO = 0 X IF ( .NOT.LSAME( UPLO , 'U' ).AND. X $ .NOT.LSAME( UPLO , 'L' ) )THEN X INFO = 1 X ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. X $ .NOT.LSAME( TRANS, 'T' ).AND. X $ .NOT.LSAME( TRANS, 'C' ) )THEN X INFO = 2 X ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. X $ .NOT.LSAME( DIAG , 'N' ) )THEN X INFO = 3 X ELSE IF( N.LT.0 )THEN X INFO = 4 X ELSE IF( LDA.LT.MAX( 1, N ) )THEN X INFO = 6 X ELSE IF( INCX.EQ.0 )THEN X INFO = 8 X END IF X IF( INFO.NE.0 )THEN X CALL XERBLA( 'DTRMV ', INFO ) X RETURN X END IF X* X* Quick return if possible. X* X IF( N.EQ.0 ) X $ RETURN X* X NOUNIT = LSAME( DIAG, 'N' ) X* X* Set up the start point in X if the increment is not unity. This X* will be ( N - 1 )*INCX too small for descending loops. X* X IF( INCX.LE.0 )THEN X KX = 1 - ( N - 1 )*INCX X ELSE IF( INCX.NE.1 )THEN X KX = 1 X END IF X* X* Start the operations. In this version the elements of A are X* accessed sequentially with one pass through A. X* X IF( LSAME( TRANS, 'N' ) )THEN X* X* Form x := A*x. X* X IF( LSAME( UPLO, 'U' ) )THEN X IF( INCX.EQ.1 )THEN X DO 20, J = 1, N X IF( X( J ).NE.ZERO )THEN X TEMP = X( J ) X DO 10, I = 1, J - 1 X X( I ) = X( I ) + TEMP*A( I, J ) X 10 CONTINUE X IF( NOUNIT ) X $ X( J ) = X( J )*A( J, J ) X END IF X 20 CONTINUE X ELSE X JX = KX X DO 40, J = 1, N X IF( X( JX ).NE.ZERO )THEN X TEMP = X( JX ) X IX = KX X DO 30, I = 1, J - 1 X X( IX ) = X( IX ) + TEMP*A( I, J ) X IX = IX + INCX X 30 CONTINUE X IF( NOUNIT ) X $ X( JX ) = X( JX )*A( J, J ) X END IF X JX = JX + INCX X 40 CONTINUE X END IF X ELSE X IF( INCX.EQ.1 )THEN X DO 60, J = N, 1, -1 X IF( X( J ).NE.ZERO )THEN X TEMP = X( J ) X DO 50, I = N, J + 1, -1 X X( I ) = X( I ) + TEMP*A( I, J ) X 50 CONTINUE X IF( NOUNIT ) X $ X( J ) = X( J )*A( J, J ) X END IF X 60 CONTINUE X ELSE X KX = KX + ( N - 1 )*INCX X JX = KX X DO 80, J = N, 1, -1 X IF( X( JX ).NE.ZERO )THEN X TEMP = X( JX ) X IX = KX X DO 70, I = N, J + 1, -1 X X( IX ) = X( IX ) + TEMP*A( I, J ) X IX = IX - INCX X 70 CONTINUE X IF( NOUNIT ) X $ X( JX ) = X( JX )*A( J, J ) X END IF X JX = JX - INCX X 80 CONTINUE X END IF X END IF X ELSE X* X* Form x := A'*x. X* X IF( LSAME( UPLO, 'U' ) )THEN X IF( INCX.EQ.1 )THEN X DO 100, J = N, 1, -1 X TEMP = X( J ) X IF( NOUNIT ) X $ TEMP = TEMP*A( J, J ) X DO 90, I = J - 1, 1, -1 X TEMP = TEMP + A( I, J )*X( I ) X 90 CONTINUE X X( J ) = TEMP X 100 CONTINUE X ELSE X JX = KX + ( N - 1 )*INCX X DO 120, J = N, 1, -1 X TEMP = X( JX ) X IX = JX X IF( NOUNIT ) X $ TEMP = TEMP*A( J, J ) X DO 110, I = J - 1, 1, -1 X IX = IX - INCX X TEMP = TEMP + A( I, J )*X( IX ) X 110 CONTINUE X X( JX ) = TEMP X JX = JX - INCX X 120 CONTINUE X END IF X ELSE X IF( INCX.EQ.1 )THEN X DO 140, J = 1, N X TEMP = X( J ) X IF( NOUNIT ) X $ TEMP = TEMP*A( J, J ) X DO 130, I = J + 1, N X TEMP = TEMP + A( I, J )*X( I ) X 130 CONTINUE X X( J ) = TEMP X 140 CONTINUE X ELSE X JX = KX X DO 160, J = 1, N X TEMP = X( JX ) X IX = JX X IF( NOUNIT ) X $ TEMP = TEMP*A( J, J ) X DO 150, I = J + 1, N X IX = IX + INCX X TEMP = TEMP + A( I, J )*X( IX ) X 150 CONTINUE X X( JX ) = TEMP X JX = JX + INCX X 160 CONTINUE X END IF X END IF X END IF X* X RETURN X* X* End of DTRMV . X* X END X* X SUBROUTINE DSYMV ( UPLO, N, ALPHA, A, LDA, X, INCX, X $ BETA, Y, INCY ) X* .. Scalar Arguments .. X DOUBLE PRECISION ALPHA, BETA X INTEGER INCX, INCY, LDA, N X CHARACTER*1 UPLO X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) X* .. X* X* Purpose X* ======= X* X* DSYMV performs the matrix-vector operation X* X* y := alpha*A*x + beta*y, X* X* where alpha and beta are scalars, x and y are n element vectors and X* A is an n by n symmetric matrix. X* X* Parameters X* ========== X* X* UPLO - CHARACTER*1. X* On entry, UPLO specifies whether the upper or lower X* triangular part of the array A is to be referenced as X* follows: X* X* UPLO = 'U' or 'u' Only the upper triangular part of A X* is to be referenced. X* X* UPLO = 'L' or 'l' Only the lower triangular part of A X* is to be referenced. X* X* Unchanged on exit. X* X* N - INTEGER. X* On entry, N specifies the order of the matrix A. X* N must be at least zero. X* Unchanged on exit. X* X* ALPHA - DOUBLE PRECISION. X* On entry, ALPHA specifies the scalar alpha. X* Unchanged on exit. X* X* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). X* Before entry with UPLO = 'U' or 'u', the leading n by n X* upper triangular part of the array A must contain the upper X* triangular part of the symmetric matrix and the strictly X* lower triangular part of A is not referenced. X* Before entry with UPLO = 'L' or 'l', the leading n by n X* lower triangular part of the array A must contain the lower X* triangular part of the symmetric matrix and the strictly X* upper triangular part of A is not referenced. X* Unchanged on exit. X* X* LDA - INTEGER. X* On entry, LDA specifies the first dimension of A as declared X* in the calling (sub) program. LDA must be at least X* max( 1, n ). X* Unchanged on exit. X* X* X - DOUBLE PRECISION array of dimension at least X* ( 1 + ( n - 1 )*abs( INCX ) ). X* Before entry, the incremented array X must contain the n X* element vector x. X* Unchanged on exit. X* X* INCX - INTEGER. X* On entry, INCX specifies the increment for the elements of X* X. INCX must not be zero. X* Unchanged on exit. X* X* BETA - DOUBLE PRECISION. X* On entry, BETA specifies the scalar beta. When BETA is X* supplied as zero then Y need not be set on input. X* Unchanged on exit. X* X* Y - DOUBLE PRECISION array of dimension at least X* ( 1 + ( n - 1 )*abs( INCY ) ). X* Before entry, the incremented array Y must contain the n X* element vector y. On exit, Y is overwritten by the updated X* vector y. X* X* INCY - INTEGER. X* On entry, INCY specifies the increment for the elements of X* Y. INCY must not be zero. X* Unchanged on exit. X* X* X* Level 2 Blas routine. X* X* -- Written on 22-October-1986. X* Jack Dongarra, Argonne National Lab. X* Jeremy Du Croz, Nag Central Office. X* Sven Hammarling, Nag Central Office. X* Richard Hanson, Sandia National Labs. X* X* X* .. Parameters .. X DOUBLE PRECISION ONE , ZERO X PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) X* .. Local Scalars .. X DOUBLE PRECISION TEMP1, TEMP2 X INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. External Subroutines .. X EXTERNAL XERBLA X* .. Intrinsic Functions .. X INTRINSIC MAX X* .. X* .. Executable Statements .. X* X* Test the input parameters. X* X INFO = 0 X IF ( .NOT.LSAME( UPLO, 'U' ).AND. X $ .NOT.LSAME( UPLO, 'L' ) )THEN X INFO = 1 X ELSE IF( N.LT.0 )THEN X INFO = 2 X ELSE IF( LDA.LT.MAX( 1, N ) )THEN X INFO = 5 X ELSE IF( INCX.EQ.0 )THEN X INFO = 7 X ELSE IF( INCY.EQ.0 )THEN X INFO = 10 X END IF X IF( INFO.NE.0 )THEN X CALL XERBLA( 'DSYMV ', INFO ) X RETURN X END IF X* X* Quick return if possible. X* X IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) X $ RETURN X* X* Set up the start points in X and Y. X* X IF( INCX.GT.0 )THEN X KX = 1 X ELSE X KX = 1 - ( N - 1 )*INCX X END IF X IF( INCY.GT.0 )THEN X KY = 1 X ELSE X KY = 1 - ( N - 1 )*INCY X END IF X* X* Start the operations. In this version the elements of A are X* accessed sequentially with one pass through the triangular part X* of A. X* X* First form y := beta*y. X* X IF( BETA.NE.ONE )THEN X IF( INCY.EQ.1 )THEN X IF( BETA.EQ.ZERO )THEN X DO 10, I = 1, N X Y( I ) = ZERO X 10 CONTINUE X ELSE X DO 20, I = 1, N X Y( I ) = BETA*Y( I ) X 20 CONTINUE X END IF X ELSE X IY = KY X IF( BETA.EQ.ZERO )THEN X DO 30, I = 1, N X Y( IY ) = ZERO X IY = IY + INCY X 30 CONTINUE X ELSE X DO 40, I = 1, N X Y( IY ) = BETA*Y( IY ) X IY = IY + INCY X 40 CONTINUE X END IF X END IF X END IF X IF( ALPHA.EQ.ZERO ) X $ RETURN X IF( LSAME( UPLO, 'U' ) )THEN X* X* Form y when A is stored in upper triangle. X* X IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN X DO 60, J = 1, N X TEMP1 = ALPHA*X( J ) X TEMP2 = ZERO X DO 50, I = 1, J - 1 X Y( I ) = Y( I ) + TEMP1*A( I, J ) X TEMP2 = TEMP2 + A( I, J )*X( I ) X 50 CONTINUE X Y( J ) = Y( J ) + TEMP1*A( J, J ) + ALPHA*TEMP2 X 60 CONTINUE X ELSE X JX = KX X JY = KY X DO 80, J = 1, N X TEMP1 = ALPHA*X( JX ) X TEMP2 = ZERO X IX = KX X IY = KY X DO 70, I = 1, J - 1 X Y( IY ) = Y( IY ) + TEMP1*A( I, J ) X TEMP2 = TEMP2 + A( I, J )*X( IX ) X IX = IX + INCX X IY = IY + INCY X 70 CONTINUE X Y( JY ) = Y( JY ) + TEMP1*A( J, J ) + ALPHA*TEMP2 X JX = JX + INCX X JY = JY + INCY X 80 CONTINUE X END IF X ELSE X* X* Form y when A is stored in lower triangle. X* X IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN X DO 100, J = 1, N X TEMP1 = ALPHA*X( J ) X TEMP2 = ZERO X Y( J ) = Y( J ) + TEMP1*A( J, J ) X DO 90, I = J + 1, N X Y( I ) = Y( I ) + TEMP1*A( I, J ) X TEMP2 = TEMP2 + A( I, J )*X( I ) X 90 CONTINUE X Y( J ) = Y( J ) + ALPHA*TEMP2 X 100 CONTINUE X ELSE X JX = KX X JY = KY X DO 120, J = 1, N X TEMP1 = ALPHA*X( JX ) X TEMP2 = ZERO X Y( JY ) = Y( JY ) + TEMP1*A( J, J ) X IX = JX X IY = JY X DO 110, I = J + 1, N X IX = IX + INCX X IY = IY + INCY X Y( IY ) = Y( IY ) + TEMP1*A( I, J ) X TEMP2 = TEMP2 + A( I, J )*X( IX ) X 110 CONTINUE X Y( JY ) = Y( JY ) + ALPHA*TEMP2 X JX = JX + INCX X JY = JY + INCY X 120 CONTINUE X END IF X END IF X* X RETURN X* X* End of DSYMV . X* X END X SUBROUTINE DTBSV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX ) X* .. Scalar Arguments .. X INTEGER INCX, K, LDA, N X CHARACTER*1 DIAG, TRANS, UPLO X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), X( * ) X* .. X* X* Purpose X* ======= X* X* DTBSV solves one of the systems of equations X* X* A*x = b, or A'*x = b, X* X* where b and x are n element vectors and A is an n by n unit, or X* non-unit, upper or lower triangular band matrix, with ( k + 1 ) X* diagonals. X* X* No test for singularity or near-singularity is included in this X* routine. Such tests must be performed before calling this routine. X* X* Parameters X* ========== X* X* UPLO - CHARACTER*1. X* On entry, UPLO specifies whether the matrix is an upper or X* lower triangular matrix as follows: X* X* UPLO = 'U' or 'u' A is an upper triangular matrix. X* X* UPLO = 'L' or 'l' A is a lower triangular matrix. X* X* Unchanged on exit. X* X* TRANS - CHARACTER*1. X* On entry, TRANS specifies the equations to be solved as X* follows: X* X* TRANS = 'N' or 'n' A*x = b. X* X* TRANS = 'T' or 't' A'*x = b. X* X* TRANS = 'C' or 'c' A'*x = b. X* X* Unchanged on exit. X* X* DIAG - CHARACTER*1. X* On entry, DIAG specifies whether or not A is unit X* triangular as follows: X* X* DIAG = 'U' or 'u' A is assumed to be unit triangular. X* X* DIAG = 'N' or 'n' A is not assumed to be unit X* triangular. X* X* Unchanged on exit. X* X* N - INTEGER. X* On entry, N specifies the order of the matrix A. X* N must be at least zero. X* Unchanged on exit. X* X* K - INTEGER. X* On entry with UPLO = 'U' or 'u', K specifies the number of X* super-diagonals of the matrix A. X* On entry with UPLO = 'L' or 'l', K specifies the number of X* sub-diagonals of the matrix A. X* K must satisfy 0 .le. K. X* Unchanged on exit. X* X* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). X* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) X* by n part of the array A must contain the upper triangular X* band part of the matrix of coefficients, supplied column by X* column, with the leading diagonal of the matrix in row X* ( k + 1 ) of the array, the first super-diagonal starting at X* position 2 in row k, and so on. The top left k by k triangle X* of the array A is not referenced. X* The following program segment will transfer an upper X* triangular band matrix from conventional full matrix storage X* to band storage: X* X* DO 20, J = 1, N X* M = K + 1 - J X* DO 10, I = MAX( 1, J - K ), J X* A( M + I, J ) = matrix( I, J ) X* 10 CONTINUE X* 20 CONTINUE X* X* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) X* by n part of the array A must contain the lower triangular X* band part of the matrix of coefficients, supplied column by X* column, with the leading diagonal of the matrix in row 1 of X* the array, the first sub-diagonal starting at position 1 in X* row 2, and so on. The bottom right k by k triangle of the X* array A is not referenced. X* The following program segment will transfer a lower X* triangular band matrix from conventional full matrix storage X* to band storage: X* X* DO 20, J = 1, N X* M = 1 - J X* DO 10, I = J, MIN( N, J + K ) X* A( M + I, J ) = matrix( I, J ) X* 10 CONTINUE X* 20 CONTINUE X* X* Note that when DIAG = 'U' or 'u' the elements of the array A X* corresponding to the diagonal elements of the matrix are not X* referenced, but are assumed to be unity. X* Unchanged on exit. X* X* LDA - INTEGER. X* On entry, LDA specifies the first dimension of A as declared X* in the calling (sub) program. LDA must be at least X* ( k + 1 ). X* Unchanged on exit. X* X* X - DOUBLE PRECISION array of dimension at least X* ( 1 + ( n - 1 )*abs( INCX ) ). X* Before entry, the incremented array X must contain the n X* element right-hand side vector b. On exit, X is overwritten X* with the solution vector x. X* X* INCX - INTEGER. X* On entry, INCX specifies the increment for the elements of X* X. INCX must not be zero. X* Unchanged on exit. X* X* X* Level 2 Blas routine. X* X* -- Written on 22-October-1986. X* Jack Dongarra, Argonne National Lab. X* Jeremy Du Croz, Nag Central Office. X* Sven Hammarling, Nag Central Office. X* Richard Hanson, Sandia National Labs. X* X* X* .. Parameters .. X DOUBLE PRECISION ZERO X PARAMETER ( ZERO = 0.0D+0 ) X* .. Local Scalars .. X DOUBLE PRECISION TEMP X INTEGER I, INFO, IX, J, JX, KPLUS1, KX, L X LOGICAL NOUNIT X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. External Subroutines .. X EXTERNAL XERBLA X* .. Intrinsic Functions .. X INTRINSIC MAX, MIN X* .. X* .. Executable Statements .. X* X* Test the input parameters. X* X INFO = 0 X IF ( .NOT.LSAME( UPLO , 'U' ).AND. X $ .NOT.LSAME( UPLO , 'L' ) )THEN X INFO = 1 X ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. X $ .NOT.LSAME( TRANS, 'T' ).AND. X $ .NOT.LSAME( TRANS, 'C' ) )THEN X INFO = 2 X ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. X $ .NOT.LSAME( DIAG , 'N' ) )THEN X INFO = 3 X ELSE IF( N.LT.0 )THEN X INFO = 4 X ELSE IF( K.LT.0 )THEN X INFO = 5 X ELSE IF( LDA.LT.( K + 1 ) )THEN X INFO = 7 X ELSE IF( INCX.EQ.0 )THEN X INFO = 9 X END IF X IF( INFO.NE.0 )THEN X CALL XERBLA( 'DTBSV ', INFO ) X RETURN X END IF X* X* Quick return if possible. X* X IF( N.EQ.0 ) X $ RETURN X* X NOUNIT = LSAME( DIAG, 'N' ) X* X* Set up the start point in X if the increment is not unity. This X* will be ( N - 1 )*INCX too small for descending loops. X* X IF( INCX.LE.0 )THEN X KX = 1 - ( N - 1 )*INCX X ELSE IF( INCX.NE.1 )THEN X KX = 1 X END IF X* X* Start the operations. In this version the elements of A are X* accessed by sequentially with one pass through A. X* X IF( LSAME( TRANS, 'N' ) )THEN X* X* Form x := inv( A )*x. X* X IF( LSAME( UPLO, 'U' ) )THEN X KPLUS1 = K + 1 X IF( INCX.EQ.1 )THEN X DO 20, J = N, 1, -1 X IF( X( J ).NE.ZERO )THEN X L = KPLUS1 - J X IF( NOUNIT ) X $ X( J ) = X( J )/A( KPLUS1, J ) X TEMP = X( J ) X DO 10, I = J - 1, MAX( 1, J - K ), -1 X X( I ) = X( I ) - TEMP*A( L + I, J ) X 10 CONTINUE X END IF X 20 CONTINUE X ELSE X KX = KX + ( N - 1 )*INCX X JX = KX X DO 40, J = N, 1, -1 X KX = KX - INCX X IF( X( JX ).NE.ZERO )THEN X IX = KX X L = KPLUS1 - J X IF( NOUNIT ) X $ X( JX ) = X( JX )/A( KPLUS1, J ) X TEMP = X( JX ) X DO 30, I = J - 1, MAX( 1, J - K ), -1 X X( IX ) = X( IX ) - TEMP*A( L + I, J ) X IX = IX - INCX X 30 CONTINUE X END IF X JX = JX - INCX X 40 CONTINUE X END IF X ELSE X IF( INCX.EQ.1 )THEN X DO 60, J = 1, N X IF( X( J ).NE.ZERO )THEN X L = 1 - J X IF( NOUNIT ) X $ X( J ) = X( J )/A( 1, J ) X TEMP = X( J ) X DO 50, I = J + 1, MIN( N, J + K ) X X( I ) = X( I ) - TEMP*A( L + I, J ) X 50 CONTINUE X END IF X 60 CONTINUE X ELSE X JX = KX X DO 80, J = 1, N X KX = KX + INCX X IF( X( JX ).NE.ZERO )THEN X IX = KX X L = 1 - J X IF( NOUNIT ) X $ X( JX ) = X( JX )/A( 1, J ) X TEMP = X( JX ) X DO 70, I = J + 1, MIN( N, J + K ) X X( IX ) = X( IX ) - TEMP*A( L + I, J ) X IX = IX + INCX X 70 CONTINUE X END IF X JX = JX + INCX X 80 CONTINUE X END IF X END IF X ELSE X* X* Form x := inv( A')*x. X* X IF( LSAME( UPLO, 'U' ) )THEN X KPLUS1 = K + 1 X IF( INCX.EQ.1 )THEN X DO 100, J = 1, N X TEMP = X( J ) X L = KPLUS1 - J X DO 90, I = MAX( 1, J - K ), J - 1 X TEMP = TEMP - A( L + I, J )*X( I ) X 90 CONTINUE X IF( NOUNIT ) X $ TEMP = TEMP/A( KPLUS1, J ) X X( J ) = TEMP X 100 CONTINUE X ELSE X JX = KX X DO 120, J = 1, N X TEMP = X( JX ) X IX = KX X L = KPLUS1 - J X DO 110, I = MAX( 1, J - K ), J - 1 X TEMP = TEMP - A( L + I, J )*X( IX ) X IX = IX + INCX X 110 CONTINUE X IF( NOUNIT ) X $ TEMP = TEMP/A( KPLUS1, J ) X X( JX ) = TEMP X JX = JX + INCX X IF( J.GT.K ) X $ KX = KX + INCX X 120 CONTINUE X END IF X ELSE X IF( INCX.EQ.1 )THEN X DO 140, J = N, 1, -1 X TEMP = X( J ) X L = 1 - J X DO 130, I = MIN( N, J + K ), J + 1, -1 X TEMP = TEMP - A( L + I, J )*X( I ) X 130 CONTINUE X IF( NOUNIT ) X $ TEMP = TEMP/A( 1, J ) X X( J ) = TEMP X 140 CONTINUE X ELSE X KX = KX + ( N - 1 )*INCX X JX = KX X DO 160, J = N, 1, -1 X TEMP = X( JX ) X IX = KX X L = 1 - J X DO 150, I = MIN( N, J + K ), J + 1, -1 X TEMP = TEMP - A( L + I, J )*X( IX ) X IX = IX - INCX X 150 CONTINUE X IF( NOUNIT ) X $ TEMP = TEMP/A( 1, J ) X X( JX ) = TEMP X JX = JX - INCX X IF( ( N - J ).GE.K ) X $ KX = KX - INCX X 160 CONTINUE X END IF X END IF X END IF X* X RETURN X* X* End of DTBSV . X* X END X SUBROUTINE DSYR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA ) X* .. Scalar Arguments .. X DOUBLE PRECISION ALPHA X INTEGER INCX, INCY, LDA, N X CHARACTER*1 UPLO X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) X* .. X* X* Purpose X* ======= X* X* DSYR2 performs the symmetric rank 2 operation X* X* A := alpha*x*y' + alpha*y*x' + A, X* X* where alpha is a scalar, x and y are n element vectors and A is an n X* by n symmetric matrix. X* X* Parameters X* ========== X* X* UPLO - CHARACTER*1. X* On entry, UPLO specifies whether the upper or lower X* triangular part of the array A is to be referenced as X* follows: X* X* UPLO = 'U' or 'u' Only the upper triangular part of A X* is to be referenced. X* X* UPLO = 'L' or 'l' Only the lower triangular part of A X* is to be referenced. X* X* Unchanged on exit. X* X* N - INTEGER. X* On entry, N specifies the order of the matrix A. X* N must be at least zero. X* Unchanged on exit. X* X* ALPHA - DOUBLE PRECISION. X* On entry, ALPHA specifies the scalar alpha. X* Unchanged on exit. X* X* X - DOUBLE PRECISION array of dimension at least X* ( 1 + ( n - 1 )*abs( INCX ) ). X* Before entry, the incremented array X must contain the n X* element vector x. X* Unchanged on exit. X* X* INCX - INTEGER. X* On entry, INCX specifies the increment for the elements of X* X. INCX must not be zero. X* Unchanged on exit. X* X* Y - DOUBLE PRECISION array of dimension at least X* ( 1 + ( n - 1 )*abs( INCY ) ). X* Before entry, the incremented array Y must contain the n X* element vector y. X* Unchanged on exit. X* X* INCY - INTEGER. X* On entry, INCY specifies the increment for the elements of X* Y. INCY must not be zero. X* Unchanged on exit. X* X* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). X* Before entry with UPLO = 'U' or 'u', the leading n by n X* upper triangular part of the array A must contain the upper X* triangular part of the symmetric matrix and the strictly X* lower triangular part of A is not referenced. On exit, the X* upper triangular part of the array A is overwritten by the X* upper triangular part of the updated matrix. X* Before entry with UPLO = 'L' or 'l', the leading n by n X* lower triangular part of the array A must contain the lower X* triangular part of the symmetric matrix and the strictly X* upper triangular part of A is not referenced. On exit, the X* lower triangular part of the array A is overwritten by the X* lower triangular part of the updated matrix. X* X* LDA - INTEGER. X* On entry, LDA specifies the first dimension of A as declared X* in the calling (sub) program. LDA must be at least X* max( 1, n ). X* Unchanged on exit. X* X* X* Level 2 Blas routine. X* X* -- Written on 22-October-1986. X* Jack Dongarra, Argonne National Lab. X* Jeremy Du Croz, Nag Central Office. X* Sven Hammarling, Nag Central Office. X* Richard Hanson, Sandia National Labs. X* X* X* .. Parameters .. X DOUBLE PRECISION ZERO X PARAMETER ( ZERO = 0.0D+0 ) X* .. Local Scalars .. X DOUBLE PRECISION TEMP1, TEMP2 X INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. External Subroutines .. X EXTERNAL XERBLA X* .. Intrinsic Functions .. X INTRINSIC MAX X* .. X* .. Executable Statements .. X* X* Test the input parameters. X* X INFO = 0 X IF ( .NOT.LSAME( UPLO, 'U' ).AND. X $ .NOT.LSAME( UPLO, 'L' ) )THEN X INFO = 1 X ELSE IF( N.LT.0 )THEN X INFO = 2 X ELSE IF( INCX.EQ.0 )THEN X INFO = 5 X ELSE IF( INCY.EQ.0 )THEN X INFO = 7 X ELSE IF( LDA.LT.MAX( 1, N ) )THEN X INFO = 9 X END IF X IF( INFO.NE.0 )THEN X CALL XERBLA( 'DSYR2 ', INFO ) X RETURN X END IF X* X* Quick return if possible. X* X IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) X $ RETURN X* X* Set up the start points in X and Y if the increments are not both X* unity. X* X IF( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN X IF( INCX.GT.0 )THEN X KX = 1 X ELSE X KX = 1 - ( N - 1 )*INCX X END IF X IF( INCY.GT.0 )THEN X KY = 1 X ELSE X KY = 1 - ( N - 1 )*INCY X END IF X JX = KX X JY = KY X END IF X* X* Start the operations. In this version the elements of A are X* accessed sequentially with one pass through the triangular part X* of A. X* X IF( LSAME( UPLO, 'U' ) )THEN X* X* Form A when A is stored in the upper triangle. X* X IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN X DO 20, J = 1, N X IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN X TEMP1 = ALPHA*Y( J ) X TEMP2 = ALPHA*X( J ) X DO 10, I = 1, J X A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 X 10 CONTINUE X END IF X 20 CONTINUE X ELSE X DO 40, J = 1, N X IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN X TEMP1 = ALPHA*Y( JY ) X TEMP2 = ALPHA*X( JX ) X IX = KX X IY = KY X DO 30, I = 1, J X A( I, J ) = A( I, J ) + X( IX )*TEMP1 X $ + Y( IY )*TEMP2 X IX = IX + INCX X IY = IY + INCY X 30 CONTINUE X END IF X JX = JX + INCX X JY = JY + INCY X 40 CONTINUE X END IF X ELSE X* X* Form A when A is stored in the lower triangle. X* X IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN X DO 60, J = 1, N X IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN X TEMP1 = ALPHA*Y( J ) X TEMP2 = ALPHA*X( J ) X DO 50, I = J, N X A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 X 50 CONTINUE X END IF X 60 CONTINUE X ELSE X DO 80, J = 1, N X IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN X TEMP1 = ALPHA*Y( JY ) X TEMP2 = ALPHA*X( JX ) X IX = JX X IY = JY X DO 70, I = J, N X A( I, J ) = A( I, J ) + X( IX )*TEMP1 X $ + Y( IY )*TEMP2 X IX = IX + INCX X IY = IY + INCY X 70 CONTINUE X END IF X JX = JX + INCX X JY = JY + INCY X 80 CONTINUE X END IF X END IF X* X RETURN X* X* End of DSYR2 . X* X END X SUBROUTINE DTRMM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, X $ B, LDB ) X* .. Scalar Arguments .. X CHARACTER*1 SIDE, UPLO, TRANSA, DIAG X INTEGER M, N, LDA, LDB X DOUBLE PRECISION ALPHA X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), B( LDB, * ) X* .. X* X* Purpose X* ======= X* X* DTRMM performs one of the matrix-matrix operations X* X* B := alpha*op( A )*B, or B := alpha*B*op( A ), X* X* where alpha is a scalar, B is an m by n matrix, A is a unit, or X* non-unit, upper or lower triangular matrix and op( A ) is one of X* X* op( A ) = A or op( A ) = A'. X* X* Parameters X* ========== X* X* SIDE - CHARACTER*1. X* On entry, SIDE specifies whether op( A ) multiplies B from X* the left or right as follows: X* X* SIDE = 'L' or 'l' B := alpha*op( A )*B. X* X* SIDE = 'R' or 'r' B := alpha*B*op( A ). X* X* Unchanged on exit. X* X* UPLO - CHARACTER*1. X* On entry, UPLO specifies whether the matrix A is an upper or X* lower triangular matrix as follows: X* X* UPLO = 'U' or 'u' A is an upper triangular matrix. X* X* UPLO = 'L' or 'l' A is a lower triangular matrix. X* X* Unchanged on exit. X* X* TRANSA - CHARACTER*1. X* On entry, TRANSA specifies the form of op( A ) to be used in X* the matrix multiplication as follows: X* X* TRANSA = 'N' or 'n' op( A ) = A. X* X* TRANSA = 'T' or 't' op( A ) = A'. X* X* TRANSA = 'C' or 'c' op( A ) = A'. X* X* Unchanged on exit. X* X* DIAG - CHARACTER*1. X* On entry, DIAG specifies whether or not A is unit triangular X* as follows: X* X* DIAG = 'U' or 'u' A is assumed to be unit triangular. X* X* DIAG = 'N' or 'n' A is not assumed to be unit X* triangular. X* X* Unchanged on exit. X* X* M - INTEGER. X* On entry, M specifies the number of rows of B. M must be at X* least zero. X* Unchanged on exit. X* X* N - INTEGER. X* On entry, N specifies the number of columns of B. N must be X* at least zero. X* Unchanged on exit. X* X* ALPHA - DOUBLE PRECISION. X* On entry, ALPHA specifies the scalar alpha. When alpha is X* zero then A is not referenced and B need not be set before X* entry. X* Unchanged on exit. X* X* A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m X* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. X* Before entry with UPLO = 'U' or 'u', the leading k by k X* upper triangular part of the array A must contain the upper X* triangular matrix and the strictly lower triangular part of X* A is not referenced. X* Before entry with UPLO = 'L' or 'l', the leading k by k X* lower triangular part of the array A must contain the lower X* triangular matrix and the strictly upper triangular part of X* A is not referenced. X* Note that when DIAG = 'U' or 'u', the diagonal elements of X* A are not referenced either, but are assumed to be unity. X* Unchanged on exit. X* X* LDA - INTEGER. X* On entry, LDA specifies the first dimension of A as declared X* in the calling (sub) program. When SIDE = 'L' or 'l' then X* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' X* then LDA must be at least max( 1, n ). X* Unchanged on exit. X* X* B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). X* Before entry, the leading m by n part of the array B must X* contain the matrix B, and on exit is overwritten by the X* transformed matrix. X* X* LDB - INTEGER. X* On entry, LDB specifies the first dimension of B as declared X* in the calling (sub) program. LDB must be at least X* max( 1, m ). X* Unchanged on exit. X* X* X* Level 3 Blas routine. X* X* -- Written on 8-February-1989. X* Jack Dongarra, Argonne National Laboratory. X* Iain Duff, AERE Harwell. X* Jeremy Du Croz, Numerical Algorithms Group Ltd. X* Sven Hammarling, Numerical Algorithms Group Ltd. X* X* X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. External Subroutines .. X EXTERNAL XERBLA X* .. Intrinsic Functions .. X INTRINSIC MAX X* .. Local Scalars .. X LOGICAL LSIDE, NOUNIT, UPPER X INTEGER I, INFO, J, K, NROWA X DOUBLE PRECISION TEMP X* .. Parameters .. X DOUBLE PRECISION ONE , ZERO X PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) X* .. X* .. Executable Statements .. X* X* Test the input parameters. X* X LSIDE = LSAME( SIDE , 'L' ) X IF( LSIDE )THEN X NROWA = M X ELSE X NROWA = N X END IF X NOUNIT = LSAME( DIAG , 'N' ) X UPPER = LSAME( UPLO , 'U' ) X* X INFO = 0 X IF( ( .NOT.LSIDE ).AND. X $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN X INFO = 1 X ELSE IF( ( .NOT.UPPER ).AND. X $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN X INFO = 2 X ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. X $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. X $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN X INFO = 3 X ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. X $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN X INFO = 4 X ELSE IF( M .LT.0 )THEN X INFO = 5 X ELSE IF( N .LT.0 )THEN X INFO = 6 X ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN X INFO = 9 X ELSE IF( LDB.LT.MAX( 1, M ) )THEN X INFO = 11 X END IF X IF( INFO.NE.0 )THEN X CALL XERBLA( 'DTRMM ', INFO ) X RETURN X END IF X* X* Quick return if possible. X* X IF( N.EQ.0 ) X $ RETURN X* X* And when alpha.eq.zero. X* X IF( ALPHA.EQ.ZERO )THEN X DO 20, J = 1, N X DO 10, I = 1, M X B( I, J ) = ZERO X 10 CONTINUE X 20 CONTINUE X RETURN X END IF X* X* Start the operations. X* X IF( LSIDE )THEN X IF( LSAME( TRANSA, 'N' ) )THEN X* X* Form B := alpha*A*B. X* X IF( UPPER )THEN X DO 50, J = 1, N X DO 40, K = 1, M X IF( B( K, J ).NE.ZERO )THEN X TEMP = ALPHA*B( K, J ) X DO 30, I = 1, K - 1 X B( I, J ) = B( I, J ) + TEMP*A( I, K ) X 30 CONTINUE X IF( NOUNIT ) X $ TEMP = TEMP*A( K, K ) X B( K, J ) = TEMP X END IF X 40 CONTINUE X 50 CONTINUE X ELSE X DO 80, J = 1, N X DO 70 K = M, 1, -1 X IF( B( K, J ).NE.ZERO )THEN X TEMP = ALPHA*B( K, J ) X B( K, J ) = TEMP X IF( NOUNIT ) X $ B( K, J ) = B( K, J )*A( K, K ) X DO 60, I = K + 1, M X B( I, J ) = B( I, J ) + TEMP*A( I, K ) X 60 CONTINUE X END IF X 70 CONTINUE X 80 CONTINUE X END IF X ELSE X* X* Form B := alpha*B*A'. X* X IF( UPPER )THEN X DO 110, J = 1, N X DO 100, I = M, 1, -1 X TEMP = B( I, J ) X IF( NOUNIT ) X $ TEMP = TEMP*A( I, I ) X DO 90, K = 1, I - 1 X TEMP = TEMP + A( K, I )*B( K, J ) X 90 CONTINUE X B( I, J ) = ALPHA*TEMP X 100 CONTINUE X 110 CONTINUE X ELSE X DO 140, J = 1, N X DO 130, I = 1, M X TEMP = B( I, J ) X IF( NOUNIT ) X $ TEMP = TEMP*A( I, I ) X DO 120, K = I + 1, M X TEMP = TEMP + A( K, I )*B( K, J ) X 120 CONTINUE X B( I, J ) = ALPHA*TEMP X 130 CONTINUE X 140 CONTINUE X END IF X END IF X ELSE X IF( LSAME( TRANSA, 'N' ) )THEN X* X* Form B := alpha*B*A. X* X IF( UPPER )THEN X DO 180, J = N, 1, -1 X TEMP = ALPHA X IF( NOUNIT ) X $ TEMP = TEMP*A( J, J ) X DO 150, I = 1, M X B( I, J ) = TEMP*B( I, J ) X 150 CONTINUE X DO 170, K = 1, J - 1 X IF( A( K, J ).NE.ZERO )THEN X TEMP = ALPHA*A( K, J ) X DO 160, I = 1, M X B( I, J ) = B( I, J ) + TEMP*B( I, K ) X 160 CONTINUE X END IF X 170 CONTINUE X 180 CONTINUE X ELSE X DO 220, J = 1, N X TEMP = ALPHA X IF( NOUNIT ) X $ TEMP = TEMP*A( J, J ) X DO 190, I = 1, M X B( I, J ) = TEMP*B( I, J ) X 190 CONTINUE X DO 210, K = J + 1, N X IF( A( K, J ).NE.ZERO )THEN X TEMP = ALPHA*A( K, J ) X DO 200, I = 1, M X B( I, J ) = B( I, J ) + TEMP*B( I, K ) X 200 CONTINUE X END IF X 210 CONTINUE X 220 CONTINUE X END IF X ELSE X* X* Form B := alpha*B*A'. X* X IF( UPPER )THEN X DO 260, K = 1, N X DO 240, J = 1, K - 1 X IF( A( J, K ).NE.ZERO )THEN X TEMP = ALPHA*A( J, K ) X DO 230, I = 1, M X B( I, J ) = B( I, J ) + TEMP*B( I, K ) X 230 CONTINUE X END IF X 240 CONTINUE X TEMP = ALPHA X IF( NOUNIT ) X $ TEMP = TEMP*A( K, K ) X IF( TEMP.NE.ONE )THEN X DO 250, I = 1, M X B( I, K ) = TEMP*B( I, K ) X 250 CONTINUE X END IF X 260 CONTINUE X ELSE X DO 300, K = N, 1, -1 X DO 280, J = K + 1, N X IF( A( J, K ).NE.ZERO )THEN X TEMP = ALPHA*A( J, K ) X DO 270, I = 1, M X B( I, J ) = B( I, J ) + TEMP*B( I, K ) X 270 CONTINUE X END IF X 280 CONTINUE X TEMP = ALPHA X IF( NOUNIT ) X $ TEMP = TEMP*A( K, K ) X IF( TEMP.NE.ONE )THEN X DO 290, I = 1, M X B( I, K ) = TEMP*B( I, K ) X 290 CONTINUE X END IF X 300 CONTINUE X END IF X END IF X END IF X* X RETURN X* X* End of DTRMM . X* X END X END_OF_FILE if test 103779 -ne `wc -c <'blas.f'`; then echo shar: \"'blas.f'\" unpacked with wrong size! fi # end of 'blas.f' fi if test -f 'correc.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'correc.f'\" else echo shar: Extracting \"'correc.f'\" \(16558 characters\) sed "s/^X//" >'correc.f' <<'END_OF_FILE' X*----------------------------------------------------------------------| X* FILE X* correc.f - corrector (preconditioner) routines X* X* This module is where to add new routine(s) for preconditioning. X* The first subroutine correc(m, ritzv, x,ldx, r,ldr) of this file X* should be modified as directed therein. X* X* The corrector is selected through a numeric identifier: X* 0 = no internal correction (NC) X* 1 = diagonal correction (DC) (default) X* 2 = tridiagonal correction (TC) X* 3 = pentadiagonal correction (PC) X* -1 = Gauss-Seidel correction (GS) X* -2 = Incomplete Choleski correction (IC) X* -3 = Exponential correction (EX) X* X* CONTENTS X* correc(m, ritzv, x,ldx, r,ldr) - wrapper to call other correctors X* corrDC(m, ritzv, x,ldx, r,ldr) - diagonal corrector X* corrTC(m, ritzv, x,ldx, r,ldr) - tridiagonal corrector X* corrPC(m, ritzv, x,ldx, r,ldr) - penta-diagonal corrector X* corrGS(m, ritzv, x,ldx, r,ldr) - Gauss-Seidel corrector X* corrGS2(m, ritzv, x,ldx, r,ldr) - Gauss-Seidel corrector (another) X* corrIC(m, ritzv, x,ldx, r,ldr) - incomplete Choleski corrector X* corrEX(m, ritzv, x,ldx, r,ldr) - exponential corrector X* X* DESCRIPTION X* X* #####################################################################| X* subroutine correc( m, ritzv, x,ldx, r,ldr ) X* include 'common.inc' X* Purpose X* wrapper that calls the relevant routine to apply a preconditioner X* Called Routines X* internal: corrDC(...) - diagonal corrector X* internal: corrTC(...) - tridiagonal corrector X* internal: corrPC(...) - penta-diagonal corrector X* internal: corrGS(...) - Gauss-Seidel corrector X* internal: corrIC(...) - incomplete Choleski corrector X* internal: corrEX(...) - exponential corrector X* Calling Routines X* runme.f: -main- X* X* #####################################################################| X* subroutine corrDC( m, ritzv, x,ldx, r,ldr ) X* include 'common.inc' X* Purpose X* computes r_j = (M-ritzv(j)*I)\r_j for j = 1:m, where M = diag(A) X* Called Routines X* -none- X* Calling Routines X* internal: correc(...) - wrapper to call other correctors X* X* #####################################################################| X* subroutine corrTC( m, ritzv, x,ldx, r,ldr ) X* include 'common.inc' X* Purpose X* computes r_j = (M-ritzv(j)*I)\r_j for j = 1:m, where M = tridiag(A) X* Called Routines X* lapack: dgtsv(...) - tridiagonal solver X* Calling Routines X* internal: correc(...) - wrapper to call other correctors X* X* #####################################################################| X* subroutine corrPC( m, ritzv, x,ldx, r,ldr ) X* include 'common.inc' X* Purpose X* computes r_j = (M-ritzv(j)*I)\r_j for j = 1:m, where M=pentadiag(A) X* Called Routines X* lapack: dgbsv(...) - banded-matrix solver X* Calling Routines X* internal: correc(...) - wrapper to call other correctors X* X* #####################################################################| X* subroutine corrGS( m, ritzv, x,ldx, r,ldr ) X* include 'common.inc' X* Purpose X* for j = 1:m, approximates r_j = (A-I*ritzv(j))\r_j with _one_ X* iteration of Gauss-Seidel using a zero initial guess. X* Called Routines X* -none- X* Calling Routines X* internal: correc(...) - wrapper to call other correctors X* X* #####################################################################| X* subroutine corrGS2( m, ritzv, x,ldx, r,ldr ) X* include 'common.inc' X* Purpose X* for j = 1:m, approximates r_j = (A-I*ritzv(j))\r_j with _one_ X* iteration of Gauss-Seidel using an arbitrary initial guess. X* Called Routines X* -none- X* Calling Routines X* -none- X* X* #####################################################################| X* subroutine corrIC( m, ritzv, x,ldx, r,ldr ) X* include 'common.inc' X* Purpose X* for j = 1:m, approximates r_j = (A-I*ritzv(j))\r_j with X* (A-I*rvmean)\r_j using an Incomplete Choleski decomposition. X* Only _one_ decomposition is performed with the shift taken as the X* mean of the Ritz values. Then this decomposition is used to apply X* backsolves on each residual vector. X* Called Routines X* ichof.f: jpildl(...) - LDL' variant of Jones-Plassmann I-Choleski X* ichof.f: invldl(...) - sparse forward and backward substitution X* Calling Routines X* internal: correc(...) - wrapper to call other correctors X* X* #####################################################################| X* subroutine corrEX( m, ritzv, x,ldx, r,ldr ) X* include 'common.inc' X* Purpose X* for j = 1:m, approximates r_j = exp(tA)r_j where t is a X* scaling-factor selected to reduce the cost of this operation. X* Called Routines X* expokit.f: dsexpv(...) - symmetric matrix exponential times vector X* Calling Routines X* internal: correc(...) - wrapper to call other correctors X* X* END DESCRIPTION X*----------------------------------------------------------------------| X* X* AUTHORS X* X* M. Sadkane - sadkane@univ-brest.fr R. B. Sidje - rbs@maths.uq.edu.au X* Departement de Mathematiques Department of Mathematics X* Universite de Bretagne Occidentale University of Queensland X* 6, Avenue Le Gorgeu, B.P. 809 Brisbane QLD 4072 X* 29285 Brest Cedex. France Australia X* X* REVISION DATE: 11/JAN/1999 X*----------------------------------------------------------------------| X X subroutine correc( m, ritzv, x,ldx, r,ldr ) X include 'common.inc' X integer m, ldx, ldr X double precision ritzv(m), x(ldx,m), r(ldr,m) X* X*----------------------------------------------------------------------| X* X* ritzv(m) : Ritz values X* X* x(ldx,m) : (input) approximations of eigenvectors X* X* r(ldr,m) : (input/output) X* On input, r contains the residual vectors. X* On output, r contains the correted vectors that will be X* used to increase the search subspace. X* Current corrections are: X* . r_j = inv(M-ritzv(j)*I) * r_j X* where M = diag(A), tridiag(A), or pentadiag(A). X* X* . r_j = inv(M_j) * r_j X* with M_j referring to *one* iteration of X* Gauss-Seidel using A-ritzv(j)*I, and a zero X* starting guess. X* X* . r_j = inv(M) * r_j X* with M referring to the Incomplete-Choleski X* (square-free LDL' variant) of A-rvmean*I. Here X* rvmean is the mean-value of the Ritz values. X* X* . r_j = exp(t*A)*x_j X* where t is a scaling-factor selected to X* reduce the cost of this operation. X* X* NOTE: inv(M) denotes the inverse of M. Of course, the X* inverse of M is never computed in isolation. This X* notation is used for convenience only. Similarly, X* the exponential is not computed in isolation. X* Rather, its action is evaluated directly. See the X* associated references for more details. X* X*----------------------------------------------------------------------| X* X*--- Add call(s) to your routine(s) for correction according to the X* pattern: if ( c_corrector.eq.your_ID ) call your_correc( ... ) X* A corrector computes r(:,j) = M_j( ritzv(j), x(:,j), r(:,j) ) X* where for j = 1...m, M_j is the preconditioner operator. X* On input: X* ritzv(1:m) are the current Ritzvalues, X* x(1:n,1:m) are the current approximate eigenvectors, X* r(1:n,1:m) are the current residual vectors. X* On output: X* r(1:n,1:m) are the new candidate vectors to add in the basis, X* other arguments should not be altered. X*--- X* X if ( c_corrector.eq.0 ) return X if ( c_corrector.eq.1 ) call corrDC( m, ritzv, x,ldx, r,ldr ) X if ( c_corrector.eq.2 ) call corrTC( m, ritzv, x,ldx, r,ldr ) X if ( c_corrector.eq.3 ) call corrPC( m, ritzv, x,ldx, r,ldr ) X* X if ( c_corrector.eq.-1 ) call corrGS( m, ritzv, x,ldx, r,ldr) X if ( c_corrector.eq.-2 ) call corrIC( m, ritzv, x,ldx, r,ldr ) X if ( c_corrector.eq.-3 ) call corrEX( m, ritzv, x,ldx, r,ldr ) X end X*----------------------------------------------------------------------| X subroutine corrDC( m, ritzv, x,ldx, r,ldr ) X include 'common.inc' X integer m, ldx, ldr X double precision ritzv(m), x(ldx,m), r(ldr,m) X intrinsic ABS, SQRT X* X*--- Diagonal Correction ... X* X integer i, j, imax, imin, IDAMAX X double precision a1,a2,a3, eps, etol, threshold X* X if ( c_tol.le.0.0d0 ) then X a1 = 4.0d0/3.0d0 X 1 a2 = a1 - 1.0d0 X a3 = a2 + a2 + a2 X eps = ABS( a3-1.0d0 ) X if ( eps.eq.0.0d0 ) goto 1 X etol = SQRT( eps ) X else X etol = c_tol X endif X imax = IDAMAX( m, ritzv,1 ) X threshold = etol*ritzv(imax) X* X do j = 1,m X imin = 1 X do i = 1,c_n X c_wrk(i) = c_diag(i,1) - ritzv(j) X if ( ABS(c_wrk(imin)).gt.ABS(c_wrk(i)) ) imin = i X enddo X if ( ABS(c_wrk(imin)).gt.threshold ) then X do i = 1,c_n X r(i,j) = r(i,j)/c_wrk(i) X enddo X endif X enddo X end X*----------------------------------------------------------------------| X subroutine corrTC( m, ritzv, x,ldx, r,ldr ) X include 'common.inc' X integer m, ldx, ldr X double precision ritzv(m), x(ldx,m), r(ldr,m) X* X*--- Tridiagonal Correction ... X* X integer i, j, ifail, ic, id, ie X* X ic = 1 X id = ic + c_n X ie = id + c_n X do j = 1,m X do i = 1,c_n-1 X c_wrk(ic+i) = c_diag(i,2) X c_wrk(id+i-1) = c_diag(i,1) - ritzv(j) X c_wrk(ie+i-1) = c_diag(i,2) X enddo X c_wrk(id+c_n-1) = c_diag(c_n,1) - ritzv(j) X call dgtsv( c_n, 1, c_wrk(ic),c_wrk(id),c_wrk(ie), X . r(1,j),ldr, ifail ) X enddo X end X*----------------------------------------------------------------------| X subroutine corrPC( m, ritzv, x,ldx, r,ldr ) X include 'common.inc' X integer m, ldx, ldr X double precision ritzv(m), x(ldx,m), r(ldr,m) X* X*--- Pentadiagonal Correction ... X* X integer i, j, ifail, ipos X* X ipos(i,j) = (j-1)*7 + i X do j = 1,m X do i = 1,c_n X c_wrk(ipos(5,i)) = c_diag(i,1) - ritzv(j) X enddo X do i = 1,c_n-1 X c_wrk(ipos(4,i+1)) = c_diag(i,2) X c_wrk(ipos(6,i)) = c_diag(i,2) X enddo X do i = 1,c_n-2 X c_wrk(ipos(3,i+2)) = c_diag(i,3) X c_wrk(ipos(7,i)) = c_diag(i,3) X enddo X call dgbsv( c_n,2,2, 1, c_wrk,7, c_iwrk, r(1,j),c_n, ifail ) X enddo X end X*----------------------------------------------------------------------| X subroutine corrGS( m, ritzv, x,ldx, r,ldr ) X include 'common.inc' X integer m, ldx, ldr X double precision ritzv(m), x(ldx,m), r(ldr,m) X* X*--- Gauss-Seidel correction ... X* X*--- Some attention is needed because only the lower triangular part is X* available column-wise. To approximate r_j = inv[A-I*ritzv(j)]*r_j, X* _one_ iteration of Gauss-Seidel is performed with a zero initial X* guess. As a result, speedy simplifications are made (see also X* corrGS2). X*--- X* X integer i, j, k X double precision dtmp X* X if ( c_mattype(1:3).ne.'hbo' .and. c_mattype(1:3).ne.'ccs' ) X . stop 'This implementation of Gauss-Seidel (corrGS) requires X . a HBO-matrix or a Compressed Column Storage (CCS) format' X X do k = 1,m X do i = 1,c_n X c_wrk(i) = 0.0d0 X enddo X do i = 1,c_n X dtmp = c_diag(i,1)-ritzv(k) X if ( dtmp.ne.0.0d0 ) then X r(i,k) = (r(i,k) - c_wrk(i))/dtmp X do j = c_ja(i)+1,c_ja(i+1)-1 X c_wrk(c_ia(j)) = c_wrk(c_ia(j)) + c_a(j)*r(i,k) X enddo X endif X enddo X enddo X end X*----------------------------------------------------------------------| X subroutine corrGS2( m, ritzv, x,ldx, r,ldr ) X include 'common.inc' X integer m, ldx, ldr X double precision ritzv(m), x(ldx,m), r(ldr,m) X* X*--- Gauss-Seidel correction ... X* X*--- Some attention is needed because only the lower triangular part is X* available column-wise. To approximate r_j = inv[A-I*ritzv(j)]*r_j, X* _one_ iteration of Gauss-Seidel is performed with a possibly non X* zero initial guess (see also corrGS). X* X* NOTE: This routine is outlined here mainly for academic purposes. X* It helps see how corrGS has been simplified. Currently, it X* is not used. However, it is a ready-to-use variant intended X* for users having some knowledge of non-zero initial guesses X* with which they may want to operate. A simple way to X* activate this routine is to rename it corrGS and rename X* the other one corrGS2 (i.e., simply swap their names). X*--- X* X integer i, j, k X double precision dtmp, rtmp X* X if ( c_mattype(1:3).ne.'hbo' .and. c_mattype(1:3).ne.'ccs' ) X . stop 'This implementation of Gauss-Seidel (corrGS) requires X . a HBO-matrix or a Compressed Column Storage (CCS) format' X X do k = 1,m X do i = 1,c_n X c_wrk(i) = 0.0d0 X c_wrk(c_n+i) = r(i,k) X*--- k-th initial guess should replace the zero assigned here ... X r(i,k) = 0.0d0 X enddo X do i = 1,c_n X dtmp = c_diag(i,1)-ritzv(k) X*--- skip correction step if zero `pivot' ... X if ( dtmp.ne.0.0d0 ) then X rtmp = c_wrk(c_n+i) - c_wrk(i) X do j = c_ja(i)+1,c_ja(i+1)-1 X rtmp = rtmp - c_a(j)*r(c_ia(j),k) X enddo X r(i,k) = rtmp/dtmp X do j = c_ja(i)+1,c_ja(i+1)-1 X c_wrk(c_ia(j)) = c_wrk(c_ia(j)) + c_a(j)*r(i,k) X enddo X endif X enddo X enddo X end X*----------------------------------------------------------------------| X subroutine corrIC( m, ritzv, x,ldx, r,ldr ) X include 'common.inc' X integer m, ldx, ldr X double precision ritzv(m), x(ldx,m), r(ldr,m) X* X*--- Incomplete Choleski correction (Incomplete LDL' variant) ... X*--- Only _one_ decomposition is performed with the shift taken as X* the mean of the Ritz values. Then the decomposition is used X* to apply backsolves on each RHS. X* X integer i, j, k, nzc, ifail, jpildl X double precision rvmean X intrinsic DBLE X* X if ( c_mattype(1:3).ne.'hbo' .and. c_mattype(1:3).ne.'ccs' ) X . stop 'This implementation of I-Choleski (corrIC) requires a HBO- X . matrix or a Compressed Column Storage (CCS) format' X X rvmean = 0.0d0 X do k = 1,m X rvmean = rvmean + ritzv(k) X enddo X rvmean = rvmean/DBLE(m) X X*--- setup the diagonal ... X do i = 1,c_n X c_diag(i,2) = c_diag(i,1) - rvmean X enddo X*--- setup the strict lower part ... X nzc = 0 X do j = 1,c_n X c_jc(j) = nzc + 1 X do i = c_ja(j)+1,c_ja(j+1)-1 X nzc = nzc + 1 X c_ac(nzc) = c_a(i) X c_ic(nzc) = c_ia(i) X enddo X enddo X c_jc(c_n+1) = nzc + 1 X X*--- Incomplete LDL' decomposition ... X ifail = jpildl( c_n, c_diag(1,2), c_ac, c_jc, c_ic, X . c_wrk, c_iwrk(1), c_iwrk(c_n+1), c_iwrk(2*c_n+1) ) X*--- Skip correction step if decomposition failed ... X if ( ifail.ne.0 ) return X*--- Backsolves ... X do k = 1,m X call invldl( c_n, c_diag(1,2), c_ac, c_jc, c_ic, r(1,k) ) X enddo X end X*----------------------------------------------------------------------| X subroutine corrEX( m, ritzv, x,ldx, r,ldr ) X include 'common.inc' X integer m, ldx, ldr X double precision ritzv(m), x(ldx,m), r(ldr,m) X* X*--- Exponential Correction ... X* X integer j, mx, itrace, iflag, lwsp, liwsp X double precision t, tol, anorm X external matv1 X X parameter( tol=1.0d-2, mx=4, lwsp=7*c_nmax, liwsp=c_nmax ) X* X itrace = 0 X anorm = c_anorm X t = 1.0d0 X* X do j = 1,m X call dsexpv( c_n, mx, t, x(1,j), r(1,j), tol, anorm, X . c_wrk,lwsp, c_iwrk,liwsp, matv1, X . itrace, iflag ) X enddo X end X*----------------------------------------------------------------------| X X X X X X X X X X END_OF_FILE if test 16558 -ne `wc -c <'correc.f'`; then echo shar: \"'correc.f'\" unpacked with wrong size! fi # end of 'correc.f' fi if test -f 'davpack.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'davpack.f'\" else echo shar: Extracting \"'davpack.f'\" \(24969 characters\) sed "s/^X//" >'davpack.f' <<'END_OF_FILE' X*----------------------------------------------------------------------| X* FILE X* davpack.f - Variable-Block Davidson algorithm with deflation X* X* CONTENTS X* subroutine davson(...) - Variable-Block Davidson with deflation X* subroutine mgs(...) - Mofified Gram-Schmidt orthogonalization X* subroutine ortho(...) - Selective orthonormal expansion X* X* DESCRIPTION X* X* #####################################################################| X* subroutine davson( n, nbx, nb, nev, itmax, iter, nmult, tol, X* . anorm, res, eig, x,ldx, wrk,lwrk, iwrk,liwrk, X* . matvec, correc, ilevel, ifile, ifail ) X* Purpose X* This is the main computational routine. It computes a few of the X* extreme (ie, rightmost or leftmost) eigenpairs of a large sparse X* symmetric matrix via the variable-block Davidson method with X* deflation. X* Called Routines X* internal: mgs(...) - Mofified Gram-Schmidt orthogonalization X* internal: ortho(...) - Selective orthonormal expansion X* external: matvec(...) - block matrix-vector multiplication routine X* external: correc(...) - corrector routine X* blas: dscal(...) - multiplication of a vector by a scalar X* blas: daxpy(...) - constant times a vector plus a vector X* blas: ddot(...) - scalar product of two vectors X* blas: dswap(...) - swaps the contents of two vectors X* blas: dnrm2(...) - euclidian norm of a vector X* blas: dcopy(...) - copies a vector into another X* blas: idamax(...) - returns index of the maximum entry of a vector X* blas: dgemm(...) - general dense matrix-matrix multiplication X* lapack: dsyevx(...) - eigenpairs of a dense symmetric matrix X* X* #####################################################################| X* subroutine mgs( n,m,k, v,ldv, x,ldx,mx ) X* Purpose X* Modified Gram-Schmidt acting on v(1:n,k:m). X* v(:,k:m) is orthogonalized against x(:,1:mx) and v(:,1:k-1). X* Called Routines X* blas: dscal(...) - multiplication of a vector by a scalar X* blas: daxpy(...) - constant times a vector plus a vector X* blas: ddot(...) - scalar product of two vectors X* blas: dnrm2(...) - euclidian norm of a vector X* Calling Routines X* internal: davson(...) - Variable-Block Davidson with deflation X* X* #####################################################################| X* subroutine ortho( n,m,nb, t,ldt, v,ldv, x,ldx,mx, kb,kbmax, drop) X* Purpose X* Selective orthonormal expansion of v(1:n,1:m) with vectors from t. X* Columns of t are orthogonalized and selectively re-orthogonalized X* against x and the current v. The resulting vector is added in v X* if its norm is greater than the drop-tolerance drop. X* Called Routines X* blas: dscal(...) - multiplication of a vector by a scalar X* blas: daxpy(...) - constant times a vector plus a vector X* blas: ddot(...) - scalar product of two vectors X* Calling Routines X* internal: davson(...) - Variable-Block Davidson with deflation X* X* END DESCRIPTION X*----------------------------------------------------------------------| X* X* AUTHORS X* X* M. Sadkane - sadkane@univ-brest.fr R. B. Sidje - rbs@maths.uq.edu.au X* Departement de Mathematiques Department of Mathematics X* Universite de Bretagne Occidentale University of Queensland X* 6, Avenue Le Gorgeu, B.P. 809 Brisbane QLD 4072 X* 29285 Brest Cedex. France Australia X* X* REVISION DATE: 11/JAN/1999 X*----------------------------------------------------------------------| X X subroutine davson( n, nbx, nb, nev, itmax, iter, nmult, tol, X . anorm, res, eig, x,ldx, wrk,lwrk, iwrk,liwrk, X . matvec, correc, ilevel, ifile, ifail ) X* X*--- variable-Block Davidson method with deflation --- X* X implicit none X integer n, nbx, nb, nev, itmax, ldx, lwrk, liwrk, nmult X double precision wrk(lwrk), res(*), eig(*), x(ldx,*), tol, anorm X integer iwrk(liwrk), ilevel, ifile, ifail X external matvec, correc X* X*-----Purpose----------------------------------------------------------| X* this subroutine computes a few extreme (ie, rightmost or leftmost) X* eigenvalues and the corresponding eigenvectors of a symmetric X* matrix by the variable-block Davidson method with deflation. X* the matrix is referenced implicitly through an external routine X* performing the sparse matrix-vector product. Upon completion, X* the computed eigenpairs are in no particular order. X* X*-----Arguments--------------------------------------------------------| X* X* n : (input) order of the symmetric matrix. X* X* nbx : (input) maximum size allowable for the basis. X* nbx .ge. mb, where mb = MAX( nb, |nev| ). X* X* nb : (input) initial block-size. X* X* nev : (input/output) number of wanted eigenpairs. X* A positive value will search for the rightmost X* eigenpairs whereas a negative value will search for the X* leftmost eigenpairs. If all of the wanted eigenpairs are X* found then, on exit nev is set to zero; otherwise |nev| X* yields the number of eigenpairs that have not converged. X* X* itmax : (input) maximum allowable number of iterations. X* X* iter : (output) number of iterations used up to convergence. X* X* nmult : (output) number of matrix-vector multiplications X* used by this routine. X* X* tol : (input) required tolerance on the residuals. X* If tol.le.0.0d0 the square root of eps is used instead. X* `eps' is the machine unit roundoff (computed internally). X* X* anorm : (input) an estimate of some norm of A. this parameter X* provides a means to select a particular convergence test: X* - If anorm>0.0d0, an eigenpair (x,lambda) with ||x|| = 1 X* is accepted if the relative residual X* ||A*x - lambda*x||/anorm <= tol. X* If anorm=1.0d0, the test is therefore based on the X* absolute residual ||A*x - lambda*x|| <= tol. X* - If anorm=0.0d0, the code uses the relative residual X* ||A*x - lambda*x||/MAX(eps^{2/3},ABS(lambda)) <= tol. X* X* res(mb): (output) the first |nev| entries have the relative X* residuals with respect to the setting of anorm above, ie. X* - If anorm > 0.0d0, then X* res = ||A*x - lambda*x||/anorm X* Thus, if anorm = 1.0d0 then res = ||A*x - lambda*x|| X* - If anorm = 0.0d0, then X* res = ||A*x-lambda*x||/MAX(eps^{2/3},ABS(lambda)) X* X* eig(mb): (output) the first |nev| entries are the eigenvalues X* that have converged. X* X* x(ldx,mb): (input/output) on entry, x should contain mb starting X* guesses (i.e., mb starting eigenvector estimations). X* On exit, the first |nev| columns contain the final X* computed eigenvector approximations. X* X* wrk(lwrk): (workspace) X* lwrk .ge. 2*n*nbx+nbx*nbx+(nbx+n)*mb+8*nbx X* Easier: lwrk .ge. (n+nbx)*(mb+nbx) + (n+8)*nbx X* Its utilization is depicted as follows: X* 2*n*nbx + nbx^2 + nbx*mb+n*mb + 8*nbx X* +--------+-------+--------------+--------------+ X* V & W=AV H eigv(H) & Residuals. wsp for LAPACK X* X* iwrk(liwrk): (workspace) liwrk .ge. 6*nbx. X* X* matvec : external subroutine for block matrix-vector product. X* synopsis: matvec( m, x,ldx, y,ldy ) X* double precision x(ldx,m), y(ldy,m) X* computes: y(1:n,1:m) <- A*x(1:n,1:m) X* where A is the principal matrix. X* X* correc : external subroutine for correction (preconditioning). X* synopsis: correc( m, x,ldx, r,ldr, ritzval ) X* double precision x(ldx,m), r(ldr,m), ritzval(m) X* computes: for j = 1:m X* r(1:n,j) <- M_j( x(1:n,j), r(1:n,j) ) X* where M_j is the preconditioner operator. X* X* ilevel : (input, info-level) specifies the amount of runtime X* information to be reported: X* 0 -Silent running 3,4 -Convergence info X* 1 -Iteration info 5 -Higly verbose (debug mode). X* 2 -Sub-iteration info X* X* ifile : (input, info-file) the logical unit of a file into which X* information will be reported: X* 0, 6 -Screen X* k -Output to file opened with unit k. If such a file X* was not opened, information goes into fort.k X* X* ifail : (output) exit completion code: X* 0 -the execution was OK X* not 0 -A problem was encountered: X* X* *A negative value means bad input arguments: X* ifail = -1 if mb.gt.n where mb = MAX( nb, |nev| ) X* ifail = -2 if nbx.gt.n .or. nbx.lt.mb X* ifail = -3 if ldx.lt.n X* ifail = -4 if liwrk.lt.6*nbx X* ifail = -5 if lwrk.lt.n*|nev|+(n+nbx)*(mb+nbx)+(n+8)*nbx X* X* Note that if inputs are not initialized properly (e.g. X* if n = 0), one or another error may be reported. X* X* *A positive value means a runtime failure occurred. X* Current exit codes are: X* ifail = 8 if a failure occurred in LAPACK when solving X* the Ritz problem. X* ifail = 9 if the maximum allowable number of iterations X* was reached without convergence of all of the X* eigenpairs. X* X* ADDITIONAL NOTES: X* ----------------- X* When the information level, ilevel > 0, the routine outputs: X* iter : current number of iterations. X* basis : current size of the basis. X* nmult : current number of matrix-vector multiplications used. X* block : current block size. X* nevf : number of eigenpairs found so far. X* residual : maximum `res' (see above). X* X*----------------------------------------------------------------------| X* X double precision zero, one X parameter( zero=0.0d0, one=1.0d0 ) X integer iv,iw,i1,i2,i3,i4, i,j,ii,ij, iter, kb,kbnew, nevf, mb, m X integer iold,ilst, ilower,iupper, ncomp,nconv, isgn, io X double precision a1, a2, a3, etol, eps, seps, eps23, residual X logical endsub X character fm*255, fm2*255, separator*80 X integer IDAMAX X double precision DNRM2 X intrinsic ABS, SQRT, MAX, MIN X X* X*--- Get working precision... X* X a1 = 4.0d0/3.0d0 X 1 a2 = a1 - 1.0d0 X a3 = a2 + a2 + a2 X eps = ABS( a3-1.0d0 ) X if ( eps.eq.0.0d0 ) goto 1 X seps = SQRT(eps) X eps23 = eps**(2.0d0/3.0d0) X X* X*--- Preliminary checks and initializations... X* X ifail = 0 X nmult = 0 X m = ABS( nev ) X mb = MAX( nb,m ) X io = ifile X if ( io.le.0 ) io = 6 X X if ( mb.gt.n ) ifail = -1 X if ( nbx.gt.n .or. nbx.lt.mb ) ifail = -2 X if ( ldx.lt.n ) ifail = -3 X if ( liwrk.lt.6*nbx ) ifail = -4 X if ( lwrk.lt.(n+nbx)*(mb+nbx)+(n+8)*nbx ) ifail = -5 X X if ( ifail.ne.0 ) then X write(UNIT=io,FMT=*) 'Bad arguments in davson '// X . '(see documentation), ifail:',ifail X return X endif X X iv = 1 X iw = iv + n*nbx X i1 = iw + n*nbx X i2 = i1 + nbx*nbx X i3 = i2 + nbx*mb X i4 = i3 + n*mb X X if ( tol.le.0.0d0 ) then X etol = seps X else X etol = tol X endif X if ( ilevel.ge.1 ) then X write(UNIT=io,FMT=*) 'machine epsilon =',eps X write(UNIT=io,FMT=*) 'tolerance used =',etol X endif X separator = "--------------------------------------------" X if ( ilevel.gt.0 .and. ilevel.le.2 ) then X write(UNIT=io,FMT='(/,A)') X . 'iter basis nmult block nevf residual' X fm = '(I4, 3x,I4, 3x,I4, 4x,I2, 6x,I1, 2x,1P,E11.3 )' X fm2 = '( 7x,I4, 3x,I4, 4x,I2, 6x,I1, 2x,1P,E11.3 )' X else X fm = '("iter =",I4, ", basis =",I3, ", nmult =",I4' // X . ',", block =",I2, ", nevf =",I1' // X . ',", residual =",1P,E11.3 )' X endif X X iter = 0 X nevf = 0 X kb = mb X X call mgs( n,kb,1, x,ldx, x,ldx,0 ) X do j = 1,kb X call DCOPY( n, x(1,j),1, wrk(iv+(j-1)*n),1 ) X enddo X X*----------------------------------------------------------------------| X*--- B E G I N N I N G O F T H E I T E R A T I O N S ---| X X if ( nev.gt.0 ) then X isgn = 1 X else X isgn = -1 X endif X X 10 continue X X ilst = 0 X iter = iter + 1 X if ( iter.gt.itmax ) then X ifail = 8 X write(UNIT=io,FMT='("Wanted=",I2," Converged=",I2)') m,nevf X write(UNIT=io,FMT=*) 'Number of iterations is reached '// X . 'without an overall convergence.' X return X endif X X*----------------------------------------------------------------------| X*--- B E G I N N I N G O F T H E S U B I T E R A T I O N S ---| X X 100 continue X X iold = ilst X ilst = ilst + kb X endsub = ilst.eq.nbx X if ( ilevel.ge.3 ) write(UNIT=io,FMT=*) 'Basis size =',ilst X X* -----------------------------------------------------------------| X*--- Interaction matrix... X* -----------------------------------------------------------------| X nmult = nmult + kb X call matvec( kb, wrk(iv+iold*n),n, wrk(iw+iold*n),n ) X call DGEMM('t','n',ilst,kb,n,one,wrk(iv),n, X . wrk(iw+iold*n),n,zero,wrk(i1+iold*nbx),nbx) X if ( iold.gt.0 ) then X*--- Restoration: replicate strict upper-part into lower-part... X ij = i1 X ii = i1 X do j = 2,ilst X ij = ij + nbx X ii = ii + 1 X call DCOPY( j-1, wrk(ij),1, wrk(ii),nbx ) X enddo X endif X if ( ilevel.ge.5 ) then X write(UNIT=io,FMT=*) 'Interaction matrix =' X do i = 1,ilst X write(UNIT=io,FMT=*) (wrk(i1+(j-1)*nbx+i-1),j=1,ilst) X enddo X endif X X* -----------------------------------------------------------------| X*--- Ritzvalues and Ritzvectors... X* -----------------------------------------------------------------| X*--- Select the range of the spectrum of interest... X if ( nev.gt.0 ) then X ilower = MAX( ilst-(mb-nevf)+1,1 ) X iupper = ilst X else X ilower = 1 X iupper = MIN( mb-nevf,ilst ) X endif X*--- Save the diagonal of the interaction matrix... X call DCOPY( ilst, wrk(i1),nbx+1, wrk(i3+nevf*n),1 ) X*--- Solve the reduce-sized Ritz problem -- the lower-part of the X* interaction matrix is destroyed... X call DSYEVX( 'v','i','l', ilst, wrk(i1),nbx, X . a1,a2, ilower,iupper, -etol, ncomp, X . eig(nevf+1), wrk(i2),nbx, X . wrk(i4),8*nbx, iwrk(1), iwrk(5*nbx+1), ifail ) X*--- Restore diagonal (strict lower-part will be restored at next iter) X call DCOPY( ilst, wrk(i3+nevf*n),1, wrk(i1),nbx+1 ) X X if ( ifail.ne.0 .or. ncomp.ne.iupper-ilower+1 ) then X ifail = 9 X write(UNIT=io,FMT=*) 'Failure in LAPACK when solving ' // X . 'the Ritz problem.' X return X endif X if ( ilevel.ge.3 ) then X write(UNIT=io,FMT=*) 'Ritzvalues =' X write(UNIT=io,FMT=*) (eig(nevf+j),j=1,ncomp) X endif X if ( ilevel.ge.5 ) then X write(UNIT=io,FMT=*) 'Ritzvectors =' X do i = 1,ilst X write(UNIT=io,FMT=*) (wrk(i2+(j-1)*nbx+i-1),j=1,ncomp) X enddo X endif X X* -----------------------------------------------------------------| X*--- Eigenvectors and Residual vectors... X* -----------------------------------------------------------------| X call DGEMM('n','n',n,ncomp,ilst,one,wrk(iv),n, X . wrk(i2),nbx,zero,x(1,nevf+1),ldx ) X call DGEMM('n','n',n,ncomp,ilst,one,wrk(iw),n, X . wrk(i2),nbx,zero,wrk(i3+nevf*n),n ) X do j = 1,ncomp X i = i3 + (nevf+j-1)*n X call DAXPY( n, -eig(nevf+j), x(1,nevf+j),1, wrk(i),1 ) X res(nevf+j) = DNRM2( n,wrk(i),1 ) X if ( anorm.gt.0.0d0 ) then X res(nevf+j) = res(nevf+j) / anorm X else X res(nevf+j) = res(nevf+j) / MAX( eps23,ABS(eig(nevf+j)) ) X endif X enddo X residual = res( IDAMAX(mb,res,1) ) X if ( ilevel.ge.3 ) then X write(UNIT=io,FMT=*) 'Residuals =' X write(UNIT=io,FMT=*) (res(nevf+j),j=1,ncomp) X endif X X* -----------------------------------------------------------------| X*--- Deflation - lock the convergent eigenpairs on the left... X* -----------------------------------------------------------------| X nconv = 0 X do j = 1,ncomp X if ( res(nevf+j).le.etol ) then X nconv = nconv + 1 X if ( nconv.ne.j ) then X call DSWAP( n, x(1,nevf+nconv),1, x(1,nevf+j),1 ) X call DSWAP( 1, res(nevf+nconv),1, res(nevf+j),1 ) X call DSWAP( 1, eig(nevf+nconv),1, eig(nevf+j),1 ) X call DSWAP( n, wrk(i3+(nevf+nconv-1)*n),1, X . wrk(i3+(nevf+j-1)*n),1 ) X endif X endif X enddo X nevf = nevf + nconv X if ( nev.gt.0 ) then X nev = nev - nconv X else X nev = nev + nconv X endif X X* -----------------------------------------------------------------| X*--- Check for completion... X* -----------------------------------------------------------------| X if ( nevf.ge.m ) then X if ( ilevel.gt.0 ) then X residual = res( IDAMAX(m,res,1) ) X write(UNIT=io,FMT=fm) iter, ilst, nmult, kb, nevf, residual X if ( ilevel.gt.1) write(UNIT=io,FMT='(A)') separator X write(UNIT=io,FMT=*) ' ' X endif X nev = 0 X return X endif X X* -----------------------------------------------------------------| X*--- Update the starting guesses that have not yet converged... X* -----------------------------------------------------------------| X iold = ilst X if ( endsub .or. nconv.ne.0 ) then X ilst = mb-nevf X call mgs( n,mb,nevf-nconv+1, x,ldx, x,ldx,0 ) X do j = 1,ilst X call DCOPY( n, x(1,nevf+j),1, wrk(iv+(j-1)*n),1 ) X enddo X endif X X* -----------------------------------------------------------------| X*--- Correction of the residuals... X* -----------------------------------------------------------------| X call correc( ncomp-nconv, eig(nevf+1), X . x(1,nevf+1),ldx, wrk(i3+nevf*n),n ) X X* -----------------------------------------------------------------| X* Selective incrementation of the basis with the corrections... X* The maximum allowable number of selections is MIN( nb, nbx-ilst ) X* (nbx-ilst is the remaining room in the basis). The number of X* corrected residuals actually selected is returned in kbnew. X* -----------------------------------------------------------------| X call ortho( n,ilst, isgn*(ncomp-nconv), wrk(i3+nevf*n),n, X . wrk(iv),n, x,ldx,nevf, kbnew,MIN(nb,nbx-ilst), X . eps ) X X* -----------------------------------------------------------------| X*--- Restart if basis size is reached, or if an eigenpair converged, X* or if none of the corrected residuals has been selected. X* the block-size kb becomes the number of current guesses augmented X* with the number of selected residuals... X* -----------------------------------------------------------------| X if ( endsub .or. nconv.ne.0 .or. kbnew.eq.0 ) then X if ( ilevel.gt.0 ) then X write(UNIT=io,FMT=fm) iter, iold, nmult, kb, nevf, residual X if ( ilevel.gt.1 ) write(UNIT=io,FMT='(A)') separator X endif X kb = mb-nevf + kbnew X call mgs( n,kb,1, wrk(iv),n, x,ldx,nevf ) X goto 10 X endif X X* -----------------------------------------------------------------| X*--- Otherwise continue with the incremented search subspace... X* -----------------------------------------------------------------| X if(ilevel.eq.2) write(UNIT=io,FMT=fm2)iold,nmult,kb,nevf,residual X kb = kbnew X goto 100 X end X*----------------------------------------------------------------------| X*::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::| X*::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::| X*::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::| X*----------------------------------------------------------------------| X subroutine mgs( n,m,k, v,ldv, x,ldx,mx ) X* X*--- Onward Modified Gram-Schmidt acting on v(:,k:m). X* v(:,k:m) is orthogonalized against x(:,1:mx) and v(:,1:k-1). X* It is assumed that x(:,1:mx) and v(:,1:k-1) are already orthogonal X* If k = 1 and mx = 0, the usual MGS is recovered. X* X implicit none X integer n, m, mx, k, ldv, ldx, i, j X double precision v(ldv,m), x(ldx,mx), s, DDOT, DNRM2 X X do i = k,m X*--- orthogonalize against x(:,1:mx) X do j = 1,mx X s = -DDOT( n, x(1,j),1, v(1,i),1 ) X call DAXPY( n, s, x(1,j),1, v(1,i),1 ) X enddo X*--- orthogonalize against v(:,1:k-1) X do j = 1,i-1 X s = -DDOT( n, v(1,j),1, v(1,i),1 ) X call DAXPY( n, s, v(1,j),1, v(1,i),1 ) X enddo X s = 1.0d0 / DNRM2( n, v(1,i),1 ) X call DSCAL( n, s, v(1,i),1 ) X enddo X end X*----------------------------------------------------------------------| X subroutine ortho( n,m,nb, t,ldt, v,ldv, x,ldx,mx, kb,kbmax, drop) X implicit none X integer n, m, nb, mx, ldt, ldv, ldx, kb, kbmax X double precision t(ldt,*), v(ldv,m+kbmax), x(ldx,mx), drop X* X*--- Selective orthonormal expansion of v(1:n,1:m) with vectors from X* t(1:n,1:|nb|). X* X*--- The selection process proceeds as follows: X* Each column of t is a candidate vector which is orthogonalized X* and selectively re-orthogonalized against x and the current v. X* The candidate is retained if its norm is greater than drop, the X* drop-tolerance. A retained candidate is normalized and included X* in v, thus it subsequently participates in the orthogonalization X* and re-orthogonalization processes against the next candidates. X* X* The sign of nb determines whether the candidates should be taken X* from t from the first to the last column, or from the last column X* to the first. this way of doing so contributes in ensuring that X* the most meaningful candidates are retained first. X* X*--- X* nb number of columns in t, nb can be positive or negative: X* positive value: the interest is in the rightmost eigenpairs, X* scan t from last column to first (backward). X* negative value: the interest is in the leftmost eigenpairs, X* scan t from first column to last (forward). X* X* kbmax specifies the maximum allowable number of vectors that can X* be selected. X* X* kb returns the actual number of vectors that have been X* selected. X*--- X* X integer j, next, istep, iorth X double precision drop2, eta, s, ss X parameter( eta=0.1d0 ) X double precision DDOT X intrinsic SQRT X X*--- Specify whether to scan the columns of t backward or forward... X if ( nb.gt.0 ) then X istep = -1 X next = nb+1 X else X istep = 1 X next = 0 X nb = -nb X endif X X*--- Orthogonalization + selective-reorthogonalisation + selection ... X kb = 0 X drop2 = drop*drop X 10 next = next + istep X if ( next.le.0 .or. next.gt.nb. or. kb.ge.kbmax ) return X iorth = 2 X 11 iorth = iorth - 1 X ss = 0.0d0 X*--- Orthogonalization against x... X do j = 1,mx X s = -DDOT( n, x(1,j),1, t(1,next),1 ) X call DAXPY( n, s, x(1,j),1, t(1,next),1 ) X ss = ss + s*s X enddo X*--- Orthogonalization against v... X do j = 1,m+kb X s = -DDOT( n, v(1,j),1, t(1,next),1 ) X call DAXPY( n, s, v(1,j),1, t(1,next),1 ) X ss = ss + s*s X enddo X*--- Selective-reorthogonalization... X s = DDOT( n, t(1,next),1, t(1,next),1 ) X if ( iorth.gt.0 .and. s.ge.drop2 .and. s.le.eta*ss ) goto 11 X*--- Selection... X if ( s.ge.drop2 ) then X kb = kb + 1 X s = SQRT( s ) X call DCOPY( n, t(1,next),1, v(1,m+kb),1 ) X call DSCAL( n, 1.0d0/s, v(1,m+kb),1 ) X endif X goto 10 X end X*----------------------------------------------------------------------| X END_OF_FILE if test 24969 -ne `wc -c <'davpack.f'`; then echo shar: \"'davpack.f'\" unpacked with wrong size! fi # end of 'davpack.f' fi if test -f 'eigsrt.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'eigsrt.f'\" else echo shar: Extracting \"'eigsrt.f'\" \(3610 characters\) sed "s/^X//" >'eigsrt.f' <<'END_OF_FILE' X*----------------------------------------------------------------------| X* FILE X* eigsrt.f - sorts the eigenvalues or residuals and moves the X* eigenvectors accordingly X* CONTENTS X* subroutine eigsrt( n, nev, res, eig, x,ldx ) X* X* DESCRIPTION X* X* #####################################################################| X* subroutine eigsrt( n, nev, res, eig, x,ldx ) X* Purpose X* Given a positive integer nev and the arrays eig(1:nev), res(1:nev) X* x(1:n,1:nev), such that x(:,j) corresponds to eig(j) and res(j), X* this routine sorts eig(1:nev) in increasing order and rearranges X* res(1:nev) and x(1:n,1:nev) so that the initial correspondence is X* maintained. X* If nev is negative, the sort of eig(1:|nev|) is done in decreasing X* order and the initial correspondence is also maintained. X* An interested user can sort the eigenpairs w.r.t residuals by X* simply inverting the role of eig and res in the call, i.e., with: X* call eigsrt( n, nev, eig, res, x,ldx ) X* Called Routines X* blas: dswap(...) - swaps the contents of two vectors X* Calling Routines X* runme.f: -main- X* alone.f: -main- X* X* END DESCRIPTION X*----------------------------------------------------------------------| X* X* AUTHORS X* X* M. Sadkane - sadkane@univ-brest.fr R. B. Sidje - rbs@maths.uq.edu.au X* Departement de Mathematiques Department of Mathematics X* Universite de Bretagne Occidentale University of Queensland X* 6, Avenue Le Gorgeu, B.P. 809 Brisbane QLD 4072 X* 29285 Brest Cedex. France Australia X* X* REVISION DATE: 11/JAN/1999 X*----------------------------------------------------------------------| X X subroutine eigsrt( n, nev, res, eig, x,ldx ) X implicit none X integer n, nev, ldx X double precision res(*), eig(*), x(ldx,*) X* X*-----Purpose----------------------------------------------------------| X* This subroutine sorts the eigenpairs w.r.t. eigenvalues. X* X*-----Arguments--------------------------------------------------------| X* X* n : (input) order of x. X* X* nev : (input) number of eigenpairs. X* A positive value will sort in increasing algebraic X* order whereas a negative value will sort in decreasing X* algebraic order. X* X* res(*) : (input/output) X* On input res(1:|nev|) are the residuals associated X* to the eigenpairs. On output these are sorted X* appropriately. X* X* eig(*) : (input/output) X* On input eig(1:|nev|) are the eigenvalues. X* On output these are sorted. X* X* x(ldx,*) : (input/output) X* On input, x(1:n,1:|nev|) are the eigenvectors. X* On output these are sorted w.r.t. the eigenvalues. X* X*--- NOTE: X* An interested user can sort the eigenpairs w.r.t residuals with: X* call eigsrt( n, nev, eig, res, x,ldx ) X* X*----------------------------------------------------------------------| X* X integer i, j, m X logical swap X intrinsic ABS X X m = ABS( nev ) X do i = 1,m-1 X do j = i+1,m X if ( nev.gt.0 ) then X swap = eig(i).gt.eig(j) X else X swap = eig(i).lt.eig(j) X endif X if ( swap ) then X call dswap( 1, res(i),1, res(j),1 ) X call dswap( 1, eig(i),1, eig(j),1 ) X call dswap( n, x(1,i),1, x(1,j),1 ) X endif X enddo X enddo X END X*----------------------------------------------------------------------| END_OF_FILE if test 3610 -ne `wc -c <'eigsrt.f'`; then echo shar: \"'eigsrt.f'\" unpacked with wrong size! fi # end of 'eigsrt.f' fi if test -f 'expokit.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'expokit.f'\" else echo shar: Extracting \"'expokit.f'\" \(26600 characters\) sed "s/^X//" >'expokit.f' <<'END_OF_FILE' X*----------------------------------------------------------------------| X* FILE X* expokit.f - matrix exponential X* X* This subset is extracted directly from the Expokit package. Only X* one change has been made. The initialization of the parameter X* mxstep = 500 was changed to mxstep = 1 in order to allow _one_ X* integration step only. Refer to the Expokit documentation for X* further details about the other arguments. X* X* CONTENTS X* subroutine DSEXPV(...) - computes exp(t*A)*v where A is symmetric X* subroutine DGPADM(...) - computes exp(t*H) in full with Pade X* subroutine DNCHBV(...) - computes exp(t*H)*y with Chebyshev X* X* DESCRIPTION X* X* #####################################################################| X* subroutine DSEXPV( n, m, t, v, w, tol, anorm, X* . wsp,lwsp, iwsp,liwsp, matvec, itrace,iflag ) X* Purpose X* computes w = exp(t*A)*v, for a symmetric matrix A. X* It uses Krylov subspace projection methods to compute directly X* the action of the matrix exponential operator on a vector without X* having to compute the matrix exponential in isolation. X* Called Routines X* internal: DGPADM(...) - computes exp(t*H) in full with Pade method X* internal: DNCHBV(...) - computes exp(t*H)*y with Chebyshev method X* external: matvec(...) - matrix-vector multiplication routine X* blas: dscal(...) - multiplication of a vector by a scalar X* blas: daxpy(...) - constant times a vector plus a vector X* blas: ddot(...) - scalar product of two vectors X* blas: dnrm2(...) - euclidian norm of a vector X* blas: dcopy(...) - copy a vector into another X* blas: dgemv(...) - general dense matrix-vector multiplication X* Calling Routines X* correc.f: corrEX(...) - exponential corrector X* X* #####################################################################| X* subroutine DGPADM( ideg,m,t,H,ldh,wsp,lwsp,ipiv,iexph,ns,iflag ) X* Purpose X* Computes exp(t*H), the matrix exponential of a general matrix in X* full, using the irreducible rational Pade approximation to the X* exponential function combined with scaling-and-squaring. X* Calling Routines X* internal: DSEXPV(...) - computes exp(t*A)*v where A is symmetric X* Called Routines X* blas: dgemm(...) - general dense matrix-matrix multiplication X* blas: dscal(...) - multiplication of a vector by a scalar X* blas: daxpy(...) - constant times a vector plus a vector X* lapack: dgesv(...) - Gaussian elimination X* X* #####################################################################| X* subroutine DNCHBV( m, t, H,ldh, y, wsp ) X* Purpose X* computes directly y = exp(t*H)*y using the partial fraction X* expansion of the uniform rational Chebyshev approximation X* to exp(-x) of type (14,14). X* Calling Routines X* internal: DSEXPV(...) - computes exp(t*A)*v where A is symmetric X* Called Routines X* blas: zswap(...) - swaps the contents of two complex vectors X* blas: zaxpy(...) - constant times a vector plus a vector (complex) X* X* END DESCRIPTION X*----------------------------------------------------------------------| X* X* AUTHORS X* X* M. Sadkane - sadkane@univ-brest.fr R. B. Sidje - rbs@maths.uq.edu.au X* Departement de Mathematiques Department of Mathematics X* Universite de Bretagne Occidentale University of Queensland X* 6, Avenue Le Gorgeu, B.P. 809 Brisbane QLD 4072 X* 29285 Brest Cedex. France Australia X* X* REVISION DATE: 11/JAN/1999 X*----------------------------------------------------------------------| X X subroutine DSEXPV( n, m, t, v, w, tol, anorm, X . wsp,lwsp, iwsp,liwsp, matvec, itrace,iflag ) X X implicit none X integer n, m, lwsp, liwsp, itrace, iflag, iwsp(liwsp) X double precision t, tol, anorm, v(n), w(n), wsp(lwsp) X external matvec X X*-----Purpose----------------------------------------------------------| X* X*--- DSEXPV computes w = exp(t*A)*v - for a Symmetric matrix A. X* X* It does not compute the matrix exponential in isolation but X* instead, it computes directly the action of the exponential X* operator on the operand vector. This way of doing so allows X* for addressing large sparse problems. X* X* The method used is based on Krylov subspace projection X* techniques and the matrix under consideration interacts only X* via the external routine `matvec' performing the matrix-vector X* product (matrix-free method). X* X*-----Arguments--------------------------------------------------------| X* X* n : (input) order of the principal matrix A. X* X* m : (input) maximum size for the Krylov basis. X* X* t : (input) time at wich the solution is needed (can be < 0). X* X* v(n) : (input) given operand vector. X* X* w(n) : (output) computed approximation of exp(t*A)*v. X* X* tol : (input/output) the requested accuracy tolerance on w. X* If on input tol=0.0d0 or tol is too small (tol.le.eps) X* the internal value sqrt(eps) is used, and tol is set to X* sqrt(eps) on output (`eps' denotes the machine epsilon). X* (`Happy breakdown' is assumed if h(j+1,j) .le. anorm*tol) X* X* anorm : (input) an approximation of some norm of A. X* X* wsp(lwsp): (workspace) lwsp .ge. n*(m+1)+n+(m+2)^2+4*(m+2)^2+ideg+1 X* +---------+-------+---------------+ X* (actually, ideg=6) V H wsp for PADE X* X* iwsp(liwsp): (workspace) liwsp .ge. m+2 X* X* matvec : external subroutine for matrix-vector multiplication. X* synopsis: matvec( x, y ) X* double precision x(*), y(*) X* computes: y(1:n) <- A*x(1:n) X* where A is the principal matrix. X* X* itrace : (input) running mode. 0=silent, 1=print step-by-step info X* X* iflag : (output) exit flag. X* <0 - bad input arguments X* 0 - no problem X* 1 - maximum number of steps reached without convergence X* 2 - requested tolerance was too high X* X*-----Accounts on the computation--------------------------------------| X* Upon exit, an interested user may retrieve accounts on the X* computations. They are located in the workspace arrays wsp and X* iwsp as indicated below: X* X* location mnemonic description X* -----------------------------------------------------------------| X* iwsp(1) = nmult, number of matrix-vector multiplications used X* iwsp(2) = nexph, nbr of Tridiagonal matrix exponential evaluated X* iwsp(3) = nscale, number of repeated squaring involved in Pade X* iwsp(4) = nstep, nbr of integration steps used up to completion X* iwsp(5) = nreject, number of rejected step-sizes X* iwsp(6) = ibrkflag, set to 1 if `happy breakdown' and 0 otherwise X* iwsp(7) = mbrkdwn, if `happy brkdown', basis-size when it occured X* -----------------------------------------------------------------| X* wsp(1) = step_min, minimum step-size used during integration X* wsp(2) = step_max, maximum step-size used during integration X* wsp(3) = dummy X* wsp(4) = dummy X* wsp(5) = x_error, maximum among all local truncation errors X* wsp(6) = s_error, global sum of local truncation errors X* wsp(7) = tbrkdwn, if `happy breakdown', time when it occured X* wsp(8) = t_now, integration domain successfully covered X* wsp(9) = hump, i.e., max||exp(sA)||, s in [0,t] (or [t,0] if t<0) X* wsp(10) = ||w||/||v||, scaled norm of the solution w. X* -----------------------------------------------------------------| X* The `hump' is a measure of the conditioning of the problem. The X* matrix exponential is well-conditioned if hump = 1, whereas it is X* poorly-conditioned if hump >> 1. However the solution can still be X* relatively fairly accurate even when the hump is large (the hump X* is an upper bound), especially when the hump and the scaled norm X* of w [this is also computed and returned in wsp(10)] are of the X* same order of magnitude (further details in reference below). X* X*----------------------------------------------------------------------| X*-----The following parameters may also be adjusted herein-------------| X* X integer mxstep, mxreject, ideg X double precision delta, gamma X parameter( mxstep = 1, X . mxreject = 0, X . ideg = 6, X . delta = 1.2d0, X . gamma = 0.9d0 ) X X* mxstep : maximum allowable number of integration steps. X* The value 0 means an infinite number of steps. X* X* mxreject: maximum allowable number of rejections at each step. X* The value 0 means an infinite number of rejections. X* X* ideg : the Pade approximation of type (ideg,ideg) is used as X* an approximation to exp(H). The value 0 switches to the X* uniform rational Chebyshev approximation of type (14,14) X* X* delta : local truncation error `safety factor' X* X* gamma : stepsize `shrinking factor' X* X*----------------------------------------------------------------------| X* Roger B. Sidje (rbs@maths.uq.edu.au) X* EXPOKIT: Software Package for Computing Matrix Exponentials. X* ACM Trans. of Math. Softw. 24(1), 130-156, 1998 X*----------------------------------------------------------------------| X* X integer i, j, k1, mh, mx, iv, ih, j1v, ns, ifree, lfree, iexph, X . ireject,ibrkflag,mbrkdwn, nmult, nreject, nexph, nscale, X . nstep X double precision sgn, t_out, tbrkdwn, step_min,step_max, err_loc, X . s_error, x_error, t_now, t_new, t_step, t_old, X . xm, beta, break_tol, p1, p2, p3, eps, rndoff, X . vnorm, avnorm, hj1j, hjj, hump, SQR1 X X intrinsic AINT,ABS,DBLE,LOG10,MAX,MIN,NINT,SIGN,SQRT X double precision DDOT, DNRM2 X X*--- check restrictions on input parameters ... X iflag = 0 X if ( lwsp.lt.n*(m+2)+5*(m+2)**2+ideg+1 ) iflag = -1 X if ( liwsp.lt.m+2 ) iflag = -2 X if ( m.ge.n .or. m.le.0 ) iflag = -3 X if ( iflag.ne.0 ) stop 'bad sizes (in input of DSEXPV)' X* X*--- initialisations ... X* X k1 = 2 X mh = m + 2 X iv = 1 X ih = iv + n*(m+1) + n X ifree = ih + mh*mh X lfree = lwsp - ifree + 1 X X ibrkflag = 0 X mbrkdwn = m X nmult = 0 X nreject = 0 X nexph = 0 X nscale = 0 X X t_out = ABS( t ) X tbrkdwn = 0.0d0 X step_min = t_out X step_max = 0.0d0 X nstep = 0 X s_error = 0.0d0 X x_error = 0.0d0 X t_now = 0.0d0 X t_new = 0.0d0 X X p1 = 4.0d0/3.0d0 X 1 p2 = p1 - 1.0d0 X p3 = p2 + p2 + p2 X eps = ABS( p3-1.0d0 ) X if ( eps.eq.0.0d0 ) go to 1 X if ( tol.le.eps ) tol = SQRT( eps ) X rndoff = eps*anorm X X break_tol = 1.0d-7 X*>>> break_tol = tol X*>>> break_tol = anorm*tol X X sgn = SIGN( 1.0d0,t ) X call DCOPY( n, v,1, w,1 ) X beta = DNRM2( n, w,1 ) X vnorm = beta X hump = beta X* X*--- obtain the very first stepsize ... X* X SQR1 = SQRT( 0.1d0 ) X xm = 1.0d0/DBLE( m ) X p1 = tol*(((m+1)/2.72D0)**(m+1))*SQRT(2.0D0*3.14D0*(m+1)) X t_new = (1.0d0/anorm)*(p1/(4.0d0*beta*anorm))**xm X p1 = 10.0d0**(NINT( LOG10( t_new )-SQR1 )-1) X t_new = AINT( t_new/p1 + 0.55d0 ) * p1 X* X*--- step-by-step integration ... X* X 100 if ( t_now.ge.t_out ) goto 500 X X nstep = nstep + 1 X t_step = MIN( t_out-t_now, t_new ) X X p1 = 1.0d0/beta X do i = 1,n X wsp(iv + i-1) = p1*w(i) X enddo X do i = 1,mh*mh X wsp(ih+i-1) = 0.0d0 X enddo X* X*--- Lanczos loop ... X* X j1v = iv + n X do 200 j = 1,m X nmult = nmult + 1 X call matvec( wsp(j1v-n), wsp(j1v) ) X if ( j.gt.1 ) X . call DAXPY(n,-wsp(ih+(j-1)*mh+j-2),wsp(j1v-2*n),1,wsp(j1v),1) X hjj = DDOT( n, wsp(j1v-n),1, wsp(j1v),1 ) X call DAXPY( n, -hjj, wsp(j1v-n),1, wsp(j1v),1 ) X hj1j = DNRM2( n, wsp(j1v),1 ) X wsp(ih+(j-1)*(mh+1)) = hjj X*--- if `happy breakdown' go straightforward at the end ... X if ( hj1j.le.break_tol ) then X print*,'happy breakdown: mbrkdwn =',j,' h =',hj1j X k1 = 0 X ibrkflag = 1 X mbrkdwn = j X tbrkdwn = t_now X t_step = t_out-t_now X goto 300 X endif X wsp(ih+(j-1)*mh+j) = hj1j X wsp(ih+j*mh+j-1) = hj1j X call DSCAL( n, 1.0d0/hj1j, wsp(j1v),1 ) X j1v = j1v + n X 200 continue X nmult = nmult + 1 X call matvec( wsp(j1v-n), wsp(j1v) ) X avnorm = DNRM2( n, wsp(j1v),1 ) X* X*--- set 1 for the 2-corrected scheme ... X* X 300 continue X wsp(ih+m*mh+m-1) = 0.0d0 X wsp(ih+m*mh+m+1) = 1.0d0 X* X*--- loop while ireject'getmat.f' <<'END_OF_FILE' X*----------------------------------------------------------------------| X* FILE X* getmat.f - get the matrix, make up corrector, get initial guesses X* X* The first subroutine getmat( x,ldx ) of this file is where to add X* call(s) to your routine(s) for loading matrix data in a format X* not currently supported by default. X* X* CONTENTS X* subroutine getmat( x,ldx ) - wrapper to call the relevant loader X* subroutine gethbo( x,ldx ) - load Harwell-Boeing matrix X* subroutine getcoo( x,ldx ) - load COOrdinates matrix X* subroutine getccs( x,ldx ) - load Compressed Column Storage matrix X* X* DESCRIPTION X* X* #####################################################################| X* subroutine getmat( x,ldx ) X* include 'common.inc' X* Purpose X* wrapper that calls the relevant routine to load a matrix depending X* on the type of the matrix at hand X* Called Routines X* internal: gethbo( x,ldx ) - load Harwell-Boeing matrix X* internal: getcoo( x,ldx ) - load COOrdinates matrix X* internal: getcss( x,ldx ) - load Compressed Column Storage matrix X* Calling Routines X* io.f: input ( x,ldx ) - initialize the argument variables X* X* #####################################################################| X* subroutine gethbo( x,ldx ) X* include 'common.inc' X* Purpose X* load a symmetric HBO matrix data and put starting guesses into x, X* compute the infinite norm of A, and extract desired diagonals for X* correction if necessary. If user supplied starting guess file, X* guesses are taken from there, otherwise, generated randomly X* Called Routines X* randm.f: randm(n,m,a,b,x,ldx) - x(1:n,1:m)=random numbers in (a,b) X* Calling Routines X* internal: getmat( x,ldx ) - wrapper to call the relevant loader X* X* #####################################################################| X* subroutine getcoo( x,ldx ) X* include 'common.inc' X* Purpose X* load a symmetric COO matrix data and put starting guesses into x, X* compute the infinite norm of A, and extract desired diagonals for X* correction if necessary. If user supplied starting guess file, X* guesses are taken from there, otherwise, generated randomly X* Called Routines X* randm.f: randm(n,m,a,b,x,ldx) - x(1:n,1:m)=random numbers in (a,b) X* Calling Routines X* internal: getmat( x,ldx ) - wrapper to load matrix data X* X* #####################################################################| X* subroutine getccs( x,ldx ) X* include 'common.inc' X* Purpose X* load a symmetric CCS matrix data and put starting guesses into x, X* compute the infinite norm of A, and extract desired diagonals for X* correction if necessary. If user supplied starting guess file, X* guesses are taken from there, otherwise, generated randomly X* Called Routines X* randm.f: randm(n,m,a,b,x,ldx) - x(1:n,1:m)=random numbers in (a,b) X* Calling Routines X* internal: getmat( x,ldx ) - wrapper to call the relevant loader X* X* END DESCRIPTION X*----------------------------------------------------------------------| X* X* AUTHORS X* X* M. Sadkane - sadkane@univ-brest.fr R. B. Sidje - rbs@maths.uq.edu.au X* Departement de Mathematiques Department of Mathematics X* Universite de Bretagne Occidentale University of Queensland X* 6, Avenue Le Gorgeu, B.P. 809 Brisbane QLD 4072 X* 29285 Brest Cedex. France Australia X* X* REVISION DATE: 11/JAN/1999 X*----------------------------------------------------------------------| X X subroutine getmat( x,ldx ) X include 'common.inc' X integer ldx X double precision x(ldx,*) X* X*--- Get symmetric matrix data and put starting guesses into x ... X* X*--- Add call(s) to your routine(s) for loading matrices according to X* the pattern: if ( c_mattype(1:3).eq.'xxx' ) call getxxx( x,ldx ) X*--- X if ( c_mattype(1:3).eq.'hbo' ) call gethbo( x,ldx ) X if ( c_mattype(1:3).eq.'coo' ) call getcoo( x,ldx ) X if ( c_mattype(1:3).eq.'ccs' ) call getccs( x,ldx ) X end X*----------------------------------------------------------------------| X subroutine gethbo( x,ldx ) X include 'common.inc' X integer ldx X double precision x(ldx,*) X* X*--- get a matrix stored under the Harwell-Boeing format ... X* X character title*72, key*8, type*3, ptrfmt*16, X . indfmt*16, valfmt*20, rhsfmt*20, rhstyp*1 X integer totcrd, ptrcrd, indcrd, valcrd, rhscrd, nrow, X . nrhs, nrhsix, i, j, k, io X intrinsic ABS, INDEX, MAX X* X*--- read heading... X k = INDEX(c_matfile,' ') - 1 X if ( k.le.0 ) then X write(*,'(A)') 'HBO matrix filename?' X read(*,'(A)') c_matfile X k = index(c_matfile,' ') - 1 X endif X open( UNIT=7, STATUS='old', IOstat=io, FILE=c_matfile(1:k) ) X if ( io.ne.0 ) then X write( c_stderr,'("Could not access the matrix: ",A)') X . c_matfile(1:k) X stop 'Could not access the matrix.' X endif X read(UNIT=7,FMT=10) title, key, X . totcrd, ptrcrd, indcrd, valcrd, rhscrd, X . type, nrow, c_N, c_NZ, nrhs, X . ptrfmt, indfmt, valfmt, rhsfmt X if ( c_infolevel.gt.0 ) then X write(c_stderr,FMT=*) title, 'type :',type,' size :',nrow,c_N X write(c_stderr,FMT=*) 'order :',c_N,' number of nonzero :',c_NZ X endif X*--- leave if matrix is non symmetric or if there are no values ... X if ( type.ne.'RSA' .or. valcrd.le.0 ) then X write(c_stderr,'("Matrix is unsymmetric...")') X stop X endif X if ( rhscrd.gt.0 ) then X read(UNIT=7,FMT=11) rhstyp, nrhs, nrhsix X write(c_stderr,'("There is a second hand")') X endif X*--- read data... X read( UNIT=7,FMT=ptrfmt ) (c_ja(i), i = 1,c_N+1) X read( UNIT=7,FMT=indfmt ) (c_ia(i), i = 1,c_NZ) X read( UNIT=7,FMT=valfmt ) (c_a(i), i = 1,c_NZ) X close( UNIT=7 ) X10 format(A72, A8/ 5i14 / A3, 11x, 4i14 / 2a16, 2a20) X11 format(A1, 13x, 2i14) X* X*--- compute the infinite norm of A ... X* X do i = 1,c_N X c_wrk(i) = 0.0d0 X enddo X do i = 1,c_NZ X c_wrk(c_ia(i)) = c_wrk(c_ia(i)) + ABS( c_a(i) ) X enddo X c_anorm = c_wrk(1) X do i = 2,c_N X if ( c_anorm.lt.c_wrk(i) ) c_anorm = c_wrk(i) X enddo X if ( c_infolevel.ge.1 ) write(c_stderr,*) '||A||_inf =',c_anorm X if ( c_infolevel.ge.2 ) write(c_stderr,'("Matrix ready...")') X* X*--- make sure the main diagonal entries are explicitly there ... X* X do i = 1,c_N X c_diag(i,1) = 0.0d0 X enddo X do j = 1,c_N X if ( c_ia(c_ja(j)).ne.j ) stop 'missing diagonal entry' X c_diag(j,1) = c_a(c_ja(j)) X if ( c_diag(j,1).eq.0.0d0 .and. c_infolevel.ge.5 ) X . write(c_stderr,'(I,"-th diagonal element is zero")') j X enddo X* X*--- extract diagonals for correction if desired ... X* X if ( c_corrector.gt.1 .and. c_corrector.le.3 ) then X do j = 1,c_corrector X do i = 1,c_N X c_diag(i,j) = 0.0d0 X enddo X enddo X do j = 1,c_N X do i = c_ja(j),c_ja(j+1)-1 X k = ABS( j-c_ia(i) ) + 1 X if ( k.le.c_corrector ) c_diag(c_ia(i),k) = c_a(i) X enddo X enddo X if (c_infolevel.ge.2) write(c_stderr,'("Corrector ready...")') X endif X* X*--- Initial starting vectors... X* X k = INDEX(c_guessfile,' ') - 1 X if ( k.gt.0 ) then X*--- User supplied starting guesses ... X open( UNIT=7, STATUS='old', IOstat=io, FILE=c_guessfile(1:k) ) X if ( io.ne.0 ) then X write(c_stderr,'("The initial guess file is absent.")') X stop "The initial guess file is absent." X endif X do i = 1,c_N X read( UNIT=7,FMT=* ) (x(i,j), j = 1,ABS(c_eigenpair)) X enddo X close( UNIT=7 ) X else X*--- Internal estimation ... (random generation) X k = MAX( c_block, ABS(c_eigenpair) ) X call randm( c_N,k, 0.0d0,1.0d0, x,ldx ) X endif X end X*----------------------------------------------------------------------| X*----------------------------------------------------------------------| X subroutine getcoo( x,ldx ) X include 'common.inc' X integer ldx X double precision x(ldx,*) X* X*--- get a matrix stored under the COOrdinates format ... X* X integer i, j, k, io X intrinsic ABS, INDEX, MAX X* X*--- open file... X k = INDEX(c_matfile,' ') - 1 X if ( k.le.0 ) then X write(*,'(A)') 'COO matrix filename?' X read(*,'(A)') c_matfile X k = index(c_matfile,' ') - 1 X endif X open( UNIT=7, STATUS='old', IOstat=io, FILE=c_matfile(1:k) ) X if ( io.ne.0 ) then X write( c_stderr,'("Could not access the matrix: ",A)' ) X . c_matfile(1:k) X stop 'Could not access the matrix.' X endif X*--- read data ... X read( UNIT=7,FMT=* ) c_N, c_NZ X do k = 1,c_NZ X read( UNIT=7,FMT=* ) c_ia(k),c_ja(k),c_a(k) X enddo X close( UNIT=7 ) X* X*--- compute the infinite norm of A ... X* X do i = 1,c_N X c_wrk(i) = 0.0d0 X enddo X do i = 1,c_NZ X c_wrk(c_ia(i)) = c_wrk(c_ia(i)) + ABS( c_a(i) ) X enddo X c_anorm = c_wrk(1) X do i = 2,c_N X if ( c_anorm.lt.c_wrk(i) ) c_anorm = c_wrk(i) X enddo X if ( c_infolevel.ge.1 ) write(c_stderr,*) '||A||_inf =',c_anorm X if ( c_infolevel.ge.2 ) write(c_stderr,'("Matrix ready...")') X* X*--- extract diagonals for correction if desired ... X* X if ( c_corrector.gt.0 .and. c_corrector.le.3 ) then X do j = 1,c_corrector X do i = 1,c_N X c_diag(i,j) = 0.0d0 X enddo X enddo X do i = 1,c_NZ X k = ABS( c_ja(i)-c_ia(i) ) + 1 X if ( k.le.c_corrector ) c_diag(c_ia(i),k) = c_a(i) X enddo X if (c_infolevel.ge.2) write(c_stderr,'("Corrector ready...")') X endif X* X*--- Initial starting vectors... X* X k = INDEX(c_guessfile,' ') - 1 X if ( k.gt.0 ) then X*--- User supplied starting guesses ... X open( UNIT=7, STATUS='old', IOstat=io, FILE=c_guessfile(1:k) ) X if ( io.ne.0 ) then X write(c_stderr,'("The initial guess file is absent.")') X stop "The initial guess file is absent." X endif X do i = 1,c_N X read( UNIT=7,FMT=* ) (x(i,j), j = 1,ABS(c_eigenpair)) X enddo X close( UNIT=7 ) X else X*--- Internal estimation ... (random generation) X k = MAX( c_block, ABS(c_eigenpair) ) X call randm( c_N,k, 0.0d0,1.0d0, x,ldx ) X endif X end X*----------------------------------------------------------------------| X*----------------------------------------------------------------------| X subroutine getccs( x,ldx ) X include 'common.inc' X integer ldx X double precision x(ldx,*) X* X*--- get a matrix stored under the Compressed Column Storage (CCS) ... X* X integer i, j, k, io X intrinsic ABS, INDEX, MAX X* X*--- open file... X k = INDEX(c_matfile,' ') - 1 X if ( k.le.0 ) then X write(*,'(A)') 'COO matrix filename?' X read(*,'(A)') c_matfile X k = index(c_matfile,' ') - 1 X endif X open( UNIT=7, STATUS='old', IOstat=io, FILE=c_matfile(1:k) ) X if ( io.ne.0 ) then X write( c_stderr,'("Could not access the matrix: ",A)' ) X . c_matfile(1:k) X stop 'Could not access the matrix.' X endif X*--- read data... X read( UNIT=7,FMT=* ) c_N, c_NZ X do k = 1,c_N+1 X read( UNIT=7,FMT=* ) c_ja(k) X enddo X do k = 1,c_NZ X read( UNIT=7,FMT=* ) c_ia(k),c_a(k) X enddo X close( UNIT=7 ) X* X*--- compute the infinite norm of A ... X* X do i = 1,c_N X c_wrk(i) = 0.0d0 X enddo X do i = 1,c_NZ X c_wrk(c_ia(i)) = c_wrk(c_ia(i)) + ABS( c_a(i) ) X enddo X c_anorm = c_wrk(1) X do i = 2,c_N X if ( c_anorm.lt.c_wrk(i) ) c_anorm = c_wrk(i) X enddo X if ( c_infolevel.ge.1 ) write(c_stderr,*) '||A||_inf =',c_anorm X if ( c_infolevel.ge.2 ) write(c_stderr,'("Matrix ready...")') X* X*--- make sure the main diagonal entries are explicitly there ... X* X do i = 1,c_N X c_diag(i,1) = 0.0d0 X enddo X do j = 1,c_N X if ( c_ia(c_ja(j)).ne.j ) stop 'missing diagonal entry' X c_diag(j,1) = c_a(c_ja(j)) X if ( c_diag(j,1).eq.0.0d0 .and. c_infolevel.ge.5 ) X . write(c_stderr,'(I,"-th diagonal element is zero")') j X enddo X* X*--- extract diagonals for correction if desired ... X* X if ( c_corrector.gt.1 .and. c_corrector.le.3 ) then X do j = 1,c_corrector X do i = 1,c_N X c_diag(i,j) = 0.0d0 X enddo X enddo X do j = 1,c_N X do i = c_ja(j),c_ja(j+1)-1 X k = ABS( j-c_ia(i) ) + 1 X if ( k.le.c_corrector ) c_diag(c_ia(i),k) = c_a(i) X enddo X enddo X if (c_infolevel.ge.2) write(c_stderr,'("Corrector ready...")') X endif X* X*--- Initial starting vectors... X* X k = INDEX(c_guessfile,' ') - 1 X if ( k.gt.0 ) then X*--- User supplied starting guesses ... X open( UNIT=7, STATUS='old', IOstat=io, FILE=c_guessfile(1:k) ) X if ( io.ne.0 ) then X write(c_stderr,'("The initial guess file is absent.")') X stop "The initial guess file is absent." X endif X do i = 1,c_N X read( UNIT=7,FMT=* ) (x(i,j), j = 1,ABS(c_eigenpair)) X enddo X close( UNIT=7 ) X else X*--- Internal estimation ... (random generation) X k = MAX( c_block, ABS(c_eigenpair) ) X call randm( c_N,k, 0.0d0,1.0d0, x,ldx ) X endif X end X*----------------------------------------------------------------------| END_OF_FILE if test 13877 -ne `wc -c <'getmat.f'`; then echo shar: \"'getmat.f'\" unpacked with wrong size! fi # end of 'getmat.f' fi if test -f 'ichol.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'ichol.f'\" else echo shar: Extracting \"'ichol.f'\" \(18636 characters\) sed "s/^X//" >'ichol.f' <<'END_OF_FILE' X*----------------------------------------------------------------------| X* FILE X* ichol.f - Incomplete square-root free Choleski LDL^T factorization X* and associated triangular-system solver X* X* This code uses a modified version of Jones and Plassmann's X* improved column-oriented Choleski decomposition published X* in Algorithm 740 of Collected Algorithms of the ACM, X* Vol. 21, No. 1, March 1995, P. 6-17 & P. 18-19. X* X* ORIGINAL COLLECTION X* ------------------- X* Algorithm 740 is a collection of the following 7 modules: X* ISTDIC: integer function that returns the standard column-oriented X* incomplete Choleski decomposition X* **JPICC: integer function that returns Jones and Plassmann's X* improved column-oriented Choleski decomposition X* JPICR: integer function that returns Jones and Plassmann's X* improved row-oriented Choleski decomposition X* *IBSORT: subroutine that returns the K largest non-zeros from X* a double precision array that is indirectly addressed by X* an integer array X* *DBSORT: subroutine to perform a bubble sort of an integer array X* *IHSORT: subroutine to perform a heap sort of a double precision X* array that is indirectly addressed by an integer array X* *DHSORT: subroutine to perform a heap sort of an integer array X* X* IN THIS FILE X* ------------ X* Only a subset of interest was taken out of Algorithm 740. The X* modules taken are those marked by an asterisk in the list above. X* The modules taken "as is" are preceded by a single asterisk: X* IBSORT, DBSORT, IHSORT, DHSORT. X* The module that was modified is preceded by two asterisks: X* JPICC. X* The original JPICC produces the improved incomplete Choleski LL^T X* decomposition. We adapted the code to produce the square-root free X* incomplete LDL^T variant. The resulting code was named JPILDL. X* We also added an associated routine not provided in Algorithm 740 X* to perform the sparse backward and forward substitution using the X* computed sparse triangular decomposition. X* X* CONTENTS X* internal: invldl( n, diag,a,ia,ja, x ) - sparse backsolver X* internal: JPILDL(N,DIAG,A,IA,JA,TA,ITCOL,IFIRST,LIST)-incom. LDL^T X* --- routines taken "as is" from Algorithm 740 --- X* internal: IBSORT(N,K,AKEYS,INDVEC) -get indices K largest nonzeros X* internal: DBSORT(N,KEYVEC) - bubble sort of integer array X* internal: IHSORT(LEN,INDVEC,AKEYS) - indirect heap sort of array X* internal: DHSORT(LEN,KEYS) - heap sort of integer array X* X* DESCRIPTION X* X* #####################################################################| X* subroutine invldl( n, diag,a,ia,ja, x ) X* Purpose X* backward & forward substitution to obtain x = L^{-T}D^{-1}L^{-1}x, X* using the incomplete square-root free Choleski LDL^T decomposition X* as produced by jpildl. X* Called Routines X* -none- X* Calling Routines X* correc.f: corrIC(m, ritzv, x,ldx, r,ldr) - Choleski corrector X* X* #####################################################################| X* INTEGER FUNCTION JPILDL(N,DIAG,A,IA,JA,TA,ITCOL,IFIRST,LIST) X* Purpose X* Adapted from JPICC (Jones and Plassmann's improved column-oriented X* Choleski decomposition). The original JPICC returns the incomplete X* LL^T decomposition. This modified version produces the square-root X* free incomplete LDL^T decomposition. X* Called Routines X* --- routines taken "as is" from Algorithm 740 --- X* internal: IBSORT(N,K,AKEYS,INDVEC) -get indices K largest nonzeros X* internal: DBSORT(N,KEYVEC) - bubble sort of integer array X* internal: IHSORT(LEN,INDVEC,AKEYS) - indirect heap sort of array X* internal: DHSORT(LEN,KEYS) - heap sort of integer array X* Calling Routines X* correc.f: corrIC(m, ritzv, x,ldx, r,ldr) - Choleski corrector X* X* END DESCRIPTION X*----------------------------------------------------------------------| X* X* AUTHORS X* X* M. Sadkane - sadkane@univ-brest.fr R. B. Sidje - rbs@maths.uq.edu.au X* Departement de Mathematiques Department of Mathematics X* Universite de Bretagne Occidentale University of Queensland X* 6, Avenue Le Gorgeu, B.P. 809 Brisbane QLD 4072 X* 29285 Brest Cedex. France Australia X* X* REVISION DATE: 11/JAN/1999 X*----------------------------------------------------------------------| X X subroutine invldl( n, diag,a,ia,ja, x ) X implicit none X integer n, ja(*), ia(*) X double precision diag(n), a(*), x(n) X* X* Sparse forward and backward substitution to obtain X* x = L^{-T}D^{-1}L^{-1}x, using the Choleski LDL^T X* decomposition in column-major order as produced by JPILDL. X* X integer i, j X* X do j = 1,n X do i = ia(j),ia(j+1)-1 X x(ja(i)) = x(ja(i)) - a(i)*x(j) X enddo X enddo X do i = 1,N X x(i) = x(i)/diag(i) X enddo X do i = N-1,1,-1 X do j = ia(i),ia(i+1)-1 X x(i) = x(i) - a(j)*x(ja(j)) X enddo X enddo X end X X*----------------------------------------------------------------------| X INTEGER FUNCTION JPILDL(N,DIAG,A,IA,JA,TA,ITCOL,IFIRST,LIST) X IMPLICIT NONE X X* Adapted from JPICC: X* JONES/PLASSMANN INCOMPLETE CHOLESKI:COLUMN ORIENTED. X* ALGORITHM 740, COLLECTED ALGORITHMS FROM ACM. X* TRANSACTIONS ON MATHEMATICAL SOFTWARE X* VOL. 21, NO. 1, MARCH, 1995, P. 6-17 & P. 18-19. X* X* Computes incomplete square-root free Choleski LDL^T decomposition. X* DIAG is diag(A) on input, and is the D-factor on output. X* See below for other arguments (these are the same as in JPICC) X X* IF THE FACTORIZATION WAS DEFINED THEN 0 IS RETURNED X* OTHERWISE A NEGATIVE VALUE IS RETURNED THAT INDICATES X* THE COLUMN NUMBER WHERE A NEGATIVE DIAGONAL WAS ENCOUNTERED X X* THE ORDER OF THE MATRIX X* INPUT ONLY X INTEGER N X* THE DIAGONALS OF A X* INPUT/OUTPUT X DOUBLE PRECISION DIAG(*) X* THE OFF-DIAGONALS OF A X* INPUT/OUTPUT X DOUBLE PRECISION A(*) X* POINTERS TO THE COLUMNS OF A X* IA(K) IS THE INDEX IN A() AND JA() WHERE COLUMN K STARTS X* ONLY THE STRICTLY LOWER TRIANGLE OF A IS STORED X* IA IS LENGTH N+1 (POSITION N+1 INDICATES WHERE COLUMN N+1 X* WOULD START IF IT EXISTED) X* INPUT X INTEGER IA(*) X* THE ROW NUMBERS OF THE OFF-DIAGONALS OF A X* INPUT/OUTPUT X INTEGER JA(*) X* A TEMPORARY WORK VECTOR OF LENGTH N TO KEEP THE CURRENT COLUMN X* CONTENTS DESTROYED X DOUBLE PRECISION TA(*) X* A TEMPORARY WORK VECTOR OF LENGTH N TO KEEP TRACK OF THE ROW X* VALUES IN THE CURRENT COLUMN X* CONTENTS DESTROYED X INTEGER ITCOL(*) X* IFIRST(J) POINTS TO THE NEXT VALUE IN COLUMN J TO USE (LENGTH N) X* IFIRST ALSO HAS A DUAL USE. AT STEP K, ONLY THE FIRST K-1 X* ELEMENTS ARE USED FOR THE ABOVE PURPOSE. FOR THE LAST N-K X* ELEMENTS, IFIRST(J) INDICATES IF IF A NONZERO VALUE EXISTS IN X* POSITION J OF COLUMN K. X* CONTENTS DESTROYED X INTEGER IFIRST(*) X* LIST(J) POINTS TO A LINKED LIST OF COLUMNS THAT WILL UPDATE X* COLUMN J (LENGTH N) X* CONTENTS DESTROYED X INTEGER LIST(*) X X* SUBROUTINES USED X EXTERNAL IBSORT, DBSORT, DHSORT X INTRINSIC ABS, SQRT X X* VARIABLES USED X INTEGER ISJ, IEJ, ISK, IEK X INTEGER I, J, K X INTEGER TALEN X INTEGER ROW, COUNT X DOUBLE PRECISION LVAL X INTEGER IPTR X X double precision EPS X parameter( EPS = 1.0d-16 ) X***************************************** X* START OF EXECUTABLE STATEMENTS X***************************************** X X DO 100 J = 1, N X IFIRST(J) = 0 X LIST(J) = 0 X100 CONTINUE X X* LOOP OVER ALL COLUMNS X DO 900 K = 1,N X* LOAD COLUMN K INTO TA X TALEN = 0 X ISK = IA(K) X IEK = IA(K+1)-1 X DO 200 J = ISK, IEK X ROW = JA(J) X TA(ROW) = A(J) X TALEN = TALEN + 1 X ITCOL(TALEN) = ROW X IFIRST(ROW) = 1 X200 CONTINUE X X* MAKE SURE THE DIAGONAL OF K IS OKAY X IF ( ABS(DIAG(K)).LE.EPS ) THEN X DIAG(K) = 0.0D0 X GOTO 1000 X ENDIF X X* UPDATE COLUMN K USING THE PREVIOUS COLUMNS X J = LIST(K) X300 CONTINUE X IF (J.EQ.0) GOTO 500 X ISJ = IFIRST(J) X IEJ = IA(J+1)-1 X LVAL = A(ISJ) X ISJ = ISJ + 1 X IF (ISJ.LT.IEJ) THEN X IFIRST(J) = ISJ X IPTR = LIST(J) X LIST(J) = LIST(JA(ISJ)) X LIST(JA(ISJ)) = J X ELSE X IPTR = LIST(J) X ENDIF X DO 400 I = ISJ, IEJ X ROW = JA(I) X IF (IFIRST(ROW).NE.0) THEN X TA(ROW) = TA(ROW) - LVAL*A(I)*DIAG(J) X ELSE X IFIRST(ROW) = 1 X TALEN = TALEN + 1 X ITCOL(TALEN) = ROW X TA(ROW) = - LVAL*A(I)*DIAG(J) X ENDIF X400 CONTINUE X J = IPTR X GOTO 300 X500 CONTINUE X X* UPDATE REMAINING DIAGONALS USING COLUMN K X DO 600 J = 1, TALEN X ROW = ITCOL(J) X TA(ROW) = TA(ROW)/DIAG(K) X DIAG(ROW) = DIAG(ROW) - TA(ROW)*TA(ROW)*DIAG(K) X600 CONTINUE X X* FIND THE LARGEST ELEMENTS IN COLUMN K NOW X COUNT = MIN(IEK-ISK+1,TALEN) X CALL IBSORT(TALEN,COUNT,TA,ITCOL) X IF (COUNT.LT.20) THEN X CALL DBSORT(COUNT,ITCOL) X ELSE X CALL DHSORT(COUNT,ITCOL) X ENDIF X X* PUT THE LARGEST ELEMENTS BACK INTO THE SPARSE DATA STRUCTURE X COUNT = 1 X DO 700 J = ISK, IEK X A(J) = TA(ITCOL(COUNT)) X JA(J) = ITCOL(COUNT) X COUNT = COUNT + 1 X700 CONTINUE X X* IFIRST AND LIST KEEP TRACK OF WHERE IN COLUMN K WE ARE X IF (ISK.LT.IEK) THEN X IPTR = JA(ISK) X LIST(K) = LIST(IPTR) X LIST(IPTR) = K X IFIRST(K) = ISK X ENDIF X X DO 800 J = 1, TALEN X IFIRST(ITCOL(J)) = 0 X800 CONTINUE X X900 CONTINUE X X JPILDL = 0 X RETURN X X* IF AN ERROR OCCURED, RETURN A NEGATIVE VALUE X1000 CONTINUE X JPILDL = -K X RETURN X***************************************************************** X* END OF JPILDL X***************************************************************** X END X***************************************************************** X* GET THE K LARGEST NONZEROES IN AKEYS INDIRECTLY ADDRESSED X* BY INDVEC; UPON EXIT THE FIRST K ELEMENTS IN INDVEC WILL X* CONTAIN THE INDICES OF THE K LARGEST ELEMENTS IN AKEYS X***************************************************************** X SUBROUTINE IBSORT(N,K,AKEYS,INDVEC) X X* THE LENGTH OF THE INTEGER VECTOR X INTEGER N X* THE NUMBER WANTED X INTEGER K X* THE DOUBLE PRECISION VECTOR TO BE SORTED X DOUBLE PRECISION AKEYS(*) X* THE INTEGER VECTOR ASSOCIATED WITH AKEYS X* INDVEC(I) GIVES THE POSITION IN AKEYS OF THE ITH ELEMENT X INTEGER INDVEC(*) X X* THE REST ARE INTERNAL VARIABLES X INTEGER I,J X INTEGER ITEMP, CURPTR, RIGHT, LEFT X DOUBLE PRECISION CURMIN, NEWVAL, CURVAL, LVAL X X EXTERNAL IHSORT X X***************************************** X* START OF EXECUTABLE STATEMENTS X***************************************** X X* IF THE LIST IS SMALL OR THE NUMBER REQUIRED IS 0 THEN X* RETURN X IF ((N.LE.1).OR.(K.LE.0)) RETURN X X* HEAP SORT THE FIRST K ELEMENTS OF THE VECTOR X CALL IHSORT(K,INDVEC,AKEYS) X X* LOOP THROUGH THE REST OF THE VECTOR AND FIND ANY ELEMENTS X* THAT ARE LARGER THAN ANY OF THE FIRST K ELEMENTS X CURMIN = ABS(AKEYS(INDVEC(K))) X DO 400 I = K+1, N X ITEMP = INDVEC(I) X NEWVAL = ABS(AKEYS(ITEMP)) X IF (NEWVAL.GT.CURMIN) THEN X* FIND POSITION FOR NEW VALUE X LEFT = 1 X LVAL = ABS(AKEYS(INDVEC(1))) X IF (NEWVAL.GT.LVAL) THEN X CURPTR = 1 X GOTO 200 X ENDIF X RIGHT = K X CURPTR = (K+1)/2 X100 CONTINUE X IF (RIGHT.GT.LEFT+1) THEN X CURVAL = ABS(AKEYS(INDVEC(CURPTR))) X IF (CURVAL.LT.NEWVAL) THEN X RIGHT = CURPTR X ELSE X LEFT = CURPTR X LVAL = CURVAL X ENDIF X CURPTR = (RIGHT+LEFT)/2 X GOTO 100 X ENDIF X CURPTR = RIGHT X X* SHIFT SORTED VALUES AND INSERT NEW VALUE X200 CONTINUE X INDVEC(I) = INDVEC(K) X DO 300 J = K, CURPTR+1, -1 X INDVEC(J) = INDVEC(J-1) X300 CONTINUE X INDVEC(CURPTR) = ITEMP X CURMIN = ABS(AKEYS(INDVEC(K))) X ENDIF X400 CONTINUE X X RETURN X***************************************************************** X* END OF IBSORT X***************************************************************** X END X***************************************************************** X* SORTS AN INTEGER VECTOR (USES BUBBLE SORT) X* ASCENDING ORDER X***************************************************************** X SUBROUTINE DBSORT(N,KEYVEC) X X* THE LENGTH OF THE VECTOR X INTEGER N X* THE INTEGER VECTOR TO BE SORTED X INTEGER KEYVEC(*) X X* THE REST ARE INTERNAL VARIABLES X INTEGER I,J X INTEGER TEMP X X***************************************** X* START OF EXECUTABLE STATEMENTS X***************************************** X DO 200 I = 1, N-1 X DO 100 J = I+1, N X IF (KEYVEC(I).GT.KEYVEC(J)) THEN X TEMP = KEYVEC(I) X KEYVEC(I) = KEYVEC(J) X KEYVEC(J) = TEMP X ENDIF X100 CONTINUE X200 CONTINUE X X RETURN X***************************************************************** X* END OF DBSORT X***************************************************************** X END X***************************************************************** X* SORTS AN INTEGER VECTOR (USES HEAP SORT) X* ASCENDING ORDER X***************************************************************** X SUBROUTINE DHSORT(LEN,KEYS) X* THE LENGTH OF THE ARRAY X INTEGER LEN X* THE ARRAY TO BE SORTED X INTEGER KEYS(*) X X* THE REST ARE INTERNAL VARIABLES X INTEGER K, M, LHEAP, RHEAP, MID X INTEGER X X X***************************************** X* START OF EXECUTABLE STATEMENTS X***************************************** X IF (LEN.LE.1) RETURN X X* BUILD THE HEAP X MID = LEN/2 X DO 300 K = MID, 1, -1 X X = KEYS(K) X LHEAP = K X RHEAP = LEN X M = LHEAP*2 X100 CONTINUE X IF (M.GT.RHEAP) THEN X KEYS(LHEAP) = X X GOTO 200 X ENDIF X IF (M.LT.RHEAP) THEN X IF (KEYS(M) .LT. KEYS(M+1)) M = M+1 X ENDIF X IF (X.GE.KEYS(M)) THEN X M = RHEAP + 1 X ELSE X KEYS(LHEAP) = KEYS(M) X LHEAP = M X M = 2*LHEAP X ENDIF X GOTO 100 X200 CONTINUE X300 CONTINUE X X* SORT THE HEAP X DO 600 K = LEN, 2, -1 X X = KEYS(K) X KEYS(K) = KEYS(1) X LHEAP = 1 X RHEAP = K-1 X M = 2 X400 CONTINUE X IF (M.GT.RHEAP) THEN X KEYS(LHEAP) = X X GOTO 500 X ENDIF X IF (M.LT.RHEAP) THEN X IF (KEYS(M) .LT. KEYS(M+1)) M = M+1 X ENDIF X IF (X.GE.KEYS(M)) THEN X M = RHEAP + 1 X ELSE X KEYS(LHEAP) = KEYS(M) X LHEAP = M X M = 2*LHEAP X ENDIF X GOTO 400 X500 CONTINUE X600 CONTINUE X X RETURN X***************************************************************** X* END OF DHSORT X***************************************************************** X END X***************************************************************** X* SORTS A DOUBLE PRECISION VECTOR INDIRECTLY ADDRESSED BY X* AN INTEGER VECTOR(USES HEAP SORT) X* THE INDVEC IS REARRANGED SUCH THAT INDVEC(1) ADDRESSES X* THE LARGEST ELEMENT IN AKEYS, INDVEC(2) ADDRESSES THE X* NEXT LARGEST .... X***************************************************************** X SUBROUTINE IHSORT(LEN,INDVEC,AKEYS) X* THE LENGTH OF THE INTEGER ARRAY X INTEGER LEN X* THE INTEGER ARRAY THAT INDIRECTLY ADDRESSES THE D.P. ARRAY X INTEGER INDVEC(*) X* THE ARRAY TO BE SORTED X DOUBLE PRECISION AKEYS(*) X X* THE REST ARE INTERNAL VARIABLES X INTEGER K, M, LHEAP, RHEAP, MID X INTEGER X X X***************************************** X* START OF EXECUTABLE STATEMENTS X***************************************** X IF (LEN.LE.1) RETURN X X* BUILD THE HEAP X MID = LEN/2 X DO 300 K = MID, 1, -1 X X = INDVEC(K) X LHEAP = K X RHEAP = LEN X M = LHEAP*2 X100 CONTINUE X IF (M.GT.RHEAP) THEN X INDVEC(LHEAP) = X X GOTO 200 X ENDIF X IF (M.LT.RHEAP) THEN X IF (ABS(AKEYS(INDVEC(M))).GT.ABS(AKEYS(INDVEC(M+1)))) X C M = M + 1 X ENDIF X IF (ABS(AKEYS(X)).LE.ABS(AKEYS(INDVEC(M)))) THEN X M = RHEAP + 1 X ELSE X INDVEC(LHEAP) = INDVEC(M) X LHEAP = M X M = 2*LHEAP X ENDIF X GOTO 100 X200 CONTINUE X300 CONTINUE X X* SORT THE HEAP X DO 600 K = LEN, 2, -1 X X = INDVEC(K) X INDVEC(K) = INDVEC(1) X LHEAP = 1 X RHEAP = K-1 X M = 2 X400 CONTINUE X IF (M.GT.RHEAP) THEN X INDVEC(LHEAP) = X X GOTO 500 X ENDIF X IF (M.LT.RHEAP) THEN X IF (ABS(AKEYS(INDVEC(M))).GT.ABS(AKEYS(INDVEC(M+1)))) X C M = M + 1 X ENDIF X IF (ABS(AKEYS(X)).LE.ABS(AKEYS(INDVEC(M)))) THEN X M = RHEAP + 1 X ELSE X INDVEC(LHEAP) = INDVEC(M) X LHEAP = M X M = 2*LHEAP X ENDIF X GOTO 400 X500 CONTINUE X600 CONTINUE X X RETURN X***************************************************************** X* END OF IHSORT X***************************************************************** X END X X X END_OF_FILE if test 18636 -ne `wc -c <'ichol.f'`; then echo shar: \"'ichol.f'\" unpacked with wrong size! fi # end of 'ichol.f' fi if test -f 'io.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'io.f'\" else echo shar: Extracting \"'io.f'\" \(12990 characters\) sed "s/^X//" >'io.f' <<'END_OF_FILE' X*----------------------------------------------------------------------| X* FILE X* io.f - input/output management X* X* CONTENTS X* subroutine input(x,ldx) -calls low-level initializers of variables X* subroutine output(res,eig,x,ldx) - outputs results of computation X* subroutine init( ) - initializes all common (global) variables X* BLOCK DATA - keeps all the default internal values X* X* DESCRIPTION X* X* #####################################################################| X* subroutine input( x,ldx ) X* include 'common.inc' X* Purpose X* routine to call low-level routines to initialize input variables X* Called Routines X* internal: init( ) - initializes all global (common) variables X* getmat.f: getmat( x,ldx ) - get matrix, corrector, initial guesses X* Calling Routines X* runme.f: -main- X* X* #####################################################################| X* subroutine output( res, eig, x,ldx ) X* include 'common.inc' X* Purpose X* routine to output the results of the computation X* Called Routines X* -none- X* Calling Routines X* runme.f: -main- X* X* #####################################################################| X* subroutine init( ) X* include 'common.inc' X* Purpose X* initializes all global inputs (ie. common variables) using either: X* - default internal values, or X* - the default file init.data if present, or X* - another file specified by the user on the command line. X* Called Routines X* -none- X* Calling Routines X* internal: input( x,ldx ) - initializes the argument variables X* X* #####################################################################| X* BLOCK DATA X* include 'common.inc' X* Purpose X* keeps all the default internal values X* X* END DESCRIPTION X*----------------------------------------------------------------------| X* X* AUTHORS X* X* M. Sadkane - sadkane@univ-brest.fr R. B. Sidje - rbs@maths.uq.edu.au X* Departement de Mathematiques Department of Mathematics X* Universite de Bretagne Occidentale University of Queensland X* 6, Avenue Le Gorgeu, B.P. 809 Brisbane QLD 4072 X* 29285 Brest Cedex. France Australia X* X* REVISION DATE: 11/JAN/1999 X*----------------------------------------------------------------------| X X subroutine input( x,ldx ) X include 'common.inc' X integer ldx X double precision x(ldx,*) X X*--- this routine calls low-level initializers of input variables... X X call init( ) X call getmat( x,ldx ) X if ( c_infolevel.ge.1 ) then X write(c_stderr,'("Input phase OK...")') X write(c_stderr,'("----------------------------------------")') X endif X end X*----------------------------------------------------------------------| X subroutine output( res, eig, x,ldx ) X include 'common.inc' X integer ldx X double precision res(*), eig(*), x(ldx,*) X X*-- Routine to output the values assigned to the paramters and the X* results of the computations X X integer n, m, i,j,k, istart,istop, istrfmt X character*80 strfmt X intrinsic ABS, INDEX X* X write(c_stdout,'("Total number of matrix * vector:" ,I4)') c_nmult X* X*--- Output parameters if necessary... X if ( c_infolevel.ge.1 ) then X write(c_stdout,'("------------- INFORMATION --------------")') X i = INDEX(c_matfile,' ')-1 X write(c_stdout,'(A,A)') ' matfile: ', c_matfile(1:i) X i = INDEX(c_mattype,' ')-1 X write(c_stdout,'(A,A)') ' mattype: ', c_mattype(1:i) X i = INDEX(c_guessfile,' ')-1 X write(c_stdout,'(A,A)') 'guessfile: ', c_guessfile(1:i) X i = INDEX(c_errfile,' ')-1 X write(c_stdout,'(A,A)') ' errfile: ', c_errfile(1:i) X i = INDEX(c_outfile,' ')-1 X write(c_stdout,'(A,A)') ' outfile: ', c_outfile(1:i) X i = INDEX(c_outfmt,' ')-1 X write(c_stdout,'(A,A)') ' outfmt: ', c_outfmt(1:i) X X write(c_stdout,'(A,I4)') 'infolevel: ', c_infolevel X write(c_stdout,'(A,I4)') ' basis: ', c_basis X write(c_stdout,'(A,I4)') ' block: ', c_block X write(c_stdout,'(A,I4)') 'eigenpair: ', c_eigenpair X write(c_stdout,'(A,I4)') 'iteration: ', c_iteration X write(c_stdout,'(A,I4)') 'corrector: ', c_corrector X write(c_stdout,'(A,I4)') ' outmax: ', c_outmax X write(c_stdout,'(A,1P,E8.2)')'tolerance: ', c_tol X write(c_stdout,'("----------------------------------------")') X endif X* X n = c_N X m = ABS( c_eigenpair ) X k = INDEX( c_outfmt,' ' ) - 1 X if ( c_outfmt(1:k).eq.'*' ) then X strfmt = '(10(X,1P,E22.15))' X else X strfmt = '(10(X,' // c_outfmt(1:k) // '))' X endif X istrfmt = INDEX( strfmt,' ' ) - 1 X X write( UNIT=c_stdout, FMT='(/,A)' ) 'RESIDUALS =' X write( UNIT=c_stdout, FMT=strfmt(1:istrfmt) ) (res(j), j=1,m) X X write( UNIT=c_stdout, FMT='(/,A)' ) 'EIGENVALUES =' X write( UNIT=c_stdout, FMT=strfmt(1:istrfmt) ) (eig(j), j=1,m) X X k = c_outmax X if ( k.eq.0 .or. k.gt.n .or. -k.ge.n ) k = n X if ( k.gt.0 ) then X istart = 1 X istop = k X else X istart = n + k + 1 X istop = n X endif X write( UNIT=c_stdout, FMT='(/,A)' ) 'EIGENVECTORS =' X do i = istart,istop X write( UNIT=c_stdout, FMT=strfmt(1:istrfmt) ) (x(i,j), j=1,m) X enddo X end X*----------------------------------------------------------------------| X subroutine init( ) X include 'common.inc' X* X* This subroutine will initialize all global inputs (i.e., common X* variables) using either: X* - default internal values, or X* - the default file init.data if present, or X* - another file specified by the user on the command line. X* X integer i,j,k,io X character*80 param X integer IARGC X intrinsic INDEX, MIN X* X*--- Check if an input file is provided on the command line... X* X i = IARGC() X if ( i.eq.0 ) then X*--- No input file, the default init.data will be used. X else if ( i.eq.1 ) then X*--- get the name of the init file supplied by the user. X call GETARG( 1,c_initfile ) X else if ( i.gt.1 ) then X write( *,'(A,/,A)' ) X . "*** Bad number of arguments.", X . "*** Specify only the file aimed at superseding init.data." X STOP X endif X* X k = INDEX( c_initfile,' ' ) - 1 X open( UNIT=7, STATUS='old', IOSTAT=io, FILE=c_initfile(1:k) ) X if ( io.ne.0 .and. c_infolevel.gt.0 ) then X write( *,'(A)' ) X . "No `" // c_initfile(1:k) // "' file. " // X . "Default internal configuration is used." X else X*--- Get I/O specifications... X 100 continue X read( UNIT=7, END=200, FMT='(A)' ) param X X*--- Debug mode: print all the lines that are read in init.data X if ( c_infolevel.ge.5 ) then X write(UNIT=*,FMT='(A,">",A)') c_initfile(1:k), param X endif X X*--- Skip the line if not relevant ... X i = INDEX(param,':')-1 X if ( i.le.0 ) goto 100 X X*--- Read the appropriate parameter ... X if ( param(1:i).eq.'matfile' ) read(7,'(A)') c_matfile X if ( param(1:i).eq.'mattype' ) read(7,'(A)') c_mattype X if ( param(1:i).eq.'guessfile' ) read(7,'(A)') c_guessfile X if ( param(1:i).eq.'errfile' ) read(7,'(A)') c_errfile X if ( param(1:i).eq.'outfile' ) read(7,'(A)') c_outfile X if ( param(1:i).eq.'outfmt' ) read(7,'(A)') c_outfmt X X if ( param(1:i).eq.'basis' ) read(7,*) c_basis X if ( param(1:i).eq.'eigenpair' ) read(7,*) c_eigenpair X if ( param(1:i).eq.'block' ) read(7,*) c_block X if ( param(1:i).eq.'iteration' ) read(7,*) c_iteration X if ( param(1:i).eq.'corrector' ) read(7,*) c_corrector X if ( param(1:i).eq.'tolerance' ) read(7,*) c_tol X if ( param(1:i).eq.'outmax' ) read(7,*) c_outmax X if ( param(1:i).eq.'infolevel') read(7,*) c_infolevel X X*--- Show the value assigned to the parameter ... X if ( c_infolevel.gt.0 ) then X X if ( param(1:i).eq.'matfile' ) then X j = INDEX(c_matfile,' ')-1 X write(*,'(A,">",A,A)') c_initfile(1:k), X . ' matfile= ', c_matfile(1:j) X endif X X if ( param(1:i).eq.'mattype' ) then X j = INDEX(c_mattype,' ')-1 X write(*,'(A,">",A,A)') c_initfile(1:k), X . ' mattype= ', c_mattype(1:j) X endif X X if ( param(1:i).eq.'guessfile' ) then X j = INDEX(c_guessfile,' ')-1 X write(*,'(A,">",A,A)') c_initfile(1:k), X . 'guessfile= ', c_guessfile(1:j) X endif X X if ( param(1:i).eq.'errfile' ) then X j = INDEX(c_errfile,' ')-1 X write(*,'(A,">",A,A)') c_initfile(1:k), X . ' errfile= ', c_errfile(1:j) X endif X X if ( param(1:i).eq.'outfile' ) then X j = INDEX(c_outfile,' ')-1 X write(*,'(A,">",A,A)') c_initfile(1:k), X . ' outfile= ', c_outfile(1:j) X endif X X if ( param(1:i).eq.'outfmt' ) then X j = INDEX(c_outfmt,' ')-1 X write(*,'(A,">",A,A)') c_initfile(1:k), X . ' outfmt= ', c_outfmt(1:j) X endif X X if ( param(1:i).eq.'infolevel') then X write(*,'(A,">",A,I4)') c_initfile(1:k), X . 'infolevel= ', c_infolevel X endif X X if ( param(1:i).eq.'basis' ) then X write(*,'(A,">",A,I4)') c_initfile(1:k), X . ' basis= ', c_basis X endif X X if ( param(1:i).eq.'block' ) then X write(*,'(A,">",A,I4)') c_initfile(1:k), X . ' block= ', c_block X endif X X if ( param(1:i).eq.'eigenpair' ) then X write(*,'(A,">",A,I4)') c_initfile(1:k), X . 'eigenpair= ', c_eigenpair X endif X X if ( param(1:i).eq.'iteration' ) then X write(*,'(A,">",A,I4)') c_initfile(1:k), X . 'iteration= ', c_iteration X endif X X if ( param(1:i).eq.'corrector' ) then X write(*,'(A,">",A,I4)') c_initfile(1:k), X . 'corrector= ', c_corrector X endif X X if ( param(1:i).eq.'outmax' ) then X write(*,'(A,">",A,I4)') c_initfile(1:k), X . ' outmax= ', c_outmax X endif X X if ( param(1:i).eq.'tolerance' ) then X write(*,'(A,">",A,1P,E8.2)') c_initfile(1:k), X . 'tolerance= ', c_tol X endif X endif X goto 100 X endif X 200 continue X X*--- Setup the error file ... X k = INDEX( c_errfile,' ' ) - 1 X if ( k.ne.0 ) then X c_stderr = 10 + c_stderr X open( UNIT=c_stderr, IOSTAT=io, FILE=c_errfile(1:k) ) X if ( io.ne.0 ) then X STOP 'Error - could not open the error file...' X endif X endif X X*--- Setup the output file ... X k = INDEX( c_outfile,' ' ) - 1 X if ( k.ne.0 ) then X c_stdout = 20 + c_stdout X open( UNIT=c_stdout, IOSTAT=io, FILE=c_outfile(1:k) ) X if ( io.ne.0 ) then X write( UNIT=c_stderr, FMT='(A)' ) X . 'Error - could not open the output file...' X STOP 'Error - could not open the output file...' X endif X endif X end X*----------------------------------------------------------------------| X*--- Do not change the following values... X*--- Customise your input/output using your file 'init.data' X* X BLOCK DATA X include 'common.inc' X data X . c_tol /1.0E-7/ X X data X . c_stdin /5/, X . c_stdout /6/, X . c_stderr /6/, X . c_infolevel /1/, X . c_corrector /1/, X . c_nmult /0/, X . c_basis /40/, X . c_block /1/, X . c_eigenpair /1/, X . c_iteration /100/, X . c_outmax /5/ X X data X . c_outfmt /'1P,E22.15'/ X . c_matfile /' '/, X . c_mattype /'hbo'/, X . c_initfile /'init.data'/, X . c_guessfile /' '/, X . c_errfile /' '/, X . c_outfile /' '/ X END X*----------------------------------------------------------------------| X END_OF_FILE if test 12990 -ne `wc -c <'io.f'`; then echo shar: \"'io.f'\" unpacked with wrong size! fi # end of 'io.f' fi if test -f 'lapack.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'lapack.f'\" else echo shar: Extracting \"'lapack.f'\" \(393036 characters\) sed "s/^X//" >'lapack.f' <<'END_OF_FILE' X SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) X* X* -- LAPACK driver routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* March 31, 1993 X* X* .. Scalar Arguments .. X INTEGER INFO, LDA, LDB, N, NRHS X* .. X* .. Array Arguments .. X INTEGER IPIV( * ) X DOUBLE PRECISION A( LDA, * ), B( LDB, * ) X* .. X* X* Purpose X* ======= X* X* DGESV computes the solution to a real system of linear equations X* A * X = B, X* where A is an N-by-N matrix and X and B are N-by-NRHS matrices. X* X* The LU decomposition with partial pivoting and row interchanges is X* used to factor A as X* A = P * L * U, X* where P is a permutation matrix, L is unit lower triangular, and U is X* upper triangular. The factored form of A is then used to solve the X* system of equations A * X = B. X* X* Arguments X* ========= X* X* N (input) INTEGER X* The number of linear equations, i.e., the order of the X* matrix A. N >= 0. X* X* NRHS (input) INTEGER X* The number of right hand sides, i.e., the number of columns X* of the matrix B. NRHS >= 0. X* X* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) X* On entry, the N-by-N coefficient matrix A. X* On exit, the factors L and U from the factorization X* A = P*L*U; the unit diagonal elements of L are not stored. X* X* LDA (input) INTEGER X* The leading dimension of the array A. LDA >= max(1,N). X* X* IPIV (output) INTEGER array, dimension (N) X* The pivot indices that define the permutation matrix P; X* row i of the matrix was interchanged with row IPIV(i). X* X* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) X* On entry, the N-by-NRHS matrix of right hand side matrix B. X* On exit, if INFO = 0, the N-by-NRHS solution matrix X. X* X* LDB (input) INTEGER X* The leading dimension of the array B. LDB >= max(1,N). X* X* INFO (output) INTEGER X* = 0: successful exit X* < 0: if INFO = -i, the i-th argument had an illegal value X* > 0: if INFO = i, U(i,i) is exactly zero. The factorization X* has been completed, but the factor U is exactly X* singular, so the solution could not be computed. X* X* ===================================================================== X* X* .. External Subroutines .. X EXTERNAL DGETRF, DGETRS, XERBLA X* .. X* .. Intrinsic Functions .. X INTRINSIC MAX X* .. X* .. Executable Statements .. X* X* Test the input parameters. X* X INFO = 0 X IF( N.LT.0 ) THEN X INFO = -1 X ELSE IF( NRHS.LT.0 ) THEN X INFO = -2 X ELSE IF( LDA.LT.MAX( 1, N ) ) THEN X INFO = -4 X ELSE IF( LDB.LT.MAX( 1, N ) ) THEN X INFO = -7 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DGESV ', -INFO ) X RETURN X END IF X* X* Compute the LU factorization of A. X* X CALL DGETRF( N, N, A, LDA, IPIV, INFO ) X IF( INFO.EQ.0 ) THEN X* X* Solve the system A*X = B, overwriting B with X. X* X CALL DGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB, X $ INFO ) X END IF X RETURN X* X* End of DGESV X* X END X* X SUBROUTINE DSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, X $ ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, X $ IFAIL, INFO ) X* X* -- LAPACK driver routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* September 30, 1994 X* X* .. Scalar Arguments .. X CHARACTER JOBZ, RANGE, UPLO X INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N X DOUBLE PRECISION ABSTOL, VL, VU X* .. X* .. Array Arguments .. X INTEGER IFAIL( * ), IWORK( * ) X DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * ) X* .. X* X* Purpose X* ======= X* X* DSYEVX computes selected eigenvalues and, optionally, eigenvectors X* of a real symmetric matrix A. Eigenvalues and eigenvectors can be X* selected by specifying either a range of values or a range of indices X* for the desired eigenvalues. X* X* Arguments X* ========= X* X* JOBZ (input) CHARACTER*1 X* = 'N': Compute eigenvalues only; X* = 'V': Compute eigenvalues and eigenvectors. X* X* RANGE (input) CHARACTER*1 X* = 'A': all eigenvalues will be found. X* = 'V': all eigenvalues in the half-open interval (VL,VU] X* will be found. X* = 'I': the IL-th through IU-th eigenvalues will be found. X* X* UPLO (input) CHARACTER*1 X* = 'U': Upper triangle of A is stored; X* = 'L': Lower triangle of A is stored. X* X* N (input) INTEGER X* The order of the matrix A. N >= 0. X* X* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) X* On entry, the symmetric matrix A. If UPLO = 'U', the X* leading N-by-N upper triangular part of A contains the X* upper triangular part of the matrix A. If UPLO = 'L', X* the leading N-by-N lower triangular part of A contains X* the lower triangular part of the matrix A. X* On exit, the lower triangle (if UPLO='L') or the upper X* triangle (if UPLO='U') of A, including the diagonal, is X* destroyed. X* X* LDA (input) INTEGER X* The leading dimension of the array A. LDA >= max(1,N). X* X* VL (input) DOUBLE PRECISION X* VU (input) DOUBLE PRECISION X* If RANGE='V', the lower and upper bounds of the interval to X* be searched for eigenvalues. VL < VU. X* Not referenced if RANGE = 'A' or 'I'. X* X* IL (input) INTEGER X* IU (input) INTEGER X* If RANGE='I', the indices (in ascending order) of the X* smallest and largest eigenvalues to be returned. X* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. X* Not referenced if RANGE = 'A' or 'V'. X* X* ABSTOL (input) DOUBLE PRECISION X* The absolute error tolerance for the eigenvalues. X* An approximate eigenvalue is accepted as converged X* when it is determined to lie in an interval [a,b] X* of width less than or equal to X* X* ABSTOL + EPS * max( |a|,|b| ) , X* X* where EPS is the machine precision. If ABSTOL is less than X* or equal to zero, then EPS*|T| will be used in its place, X* where |T| is the 1-norm of the tridiagonal matrix obtained X* by reducing A to tridiagonal form. X* X* Eigenvalues will be computed most accurately when ABSTOL is X* set to twice the underflow threshold 2*DLAMCH('S'), not zero. X* If this routine returns with INFO>0, indicating that some X* eigenvectors did not converge, try setting ABSTOL to X* 2*DLAMCH('S'). X* X* See "Computing Small Singular Values of Bidiagonal Matrices X* with Guaranteed High Relative Accuracy," by Demmel and X* Kahan, LAPACK Working Note #3. X* X* M (output) INTEGER X* The total number of eigenvalues found. 0 <= M <= N. X* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. X* X* W (output) DOUBLE PRECISION array, dimension (N) X* On normal exit, the first M elements contain the selected X* eigenvalues in ascending order. X* X* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M)) X* If JOBZ = 'V', then if INFO = 0, the first M columns of Z X* contain the orthonormal eigenvectors of the matrix A X* corresponding to the selected eigenvalues, with the i-th X* column of Z holding the eigenvector associated with W(i). X* If an eigenvector fails to converge, then that column of Z X* contains the latest approximation to the eigenvector, and the X* index of the eigenvector is returned in IFAIL. X* If JOBZ = 'N', then Z is not referenced. X* Note: the user must ensure that at least max(1,M) columns are X* supplied in the array Z; if RANGE = 'V', the exact value of M X* is not known in advance and an upper bound must be used. X* X* LDZ (input) INTEGER X* The leading dimension of the array Z. LDZ >= 1, and if X* JOBZ = 'V', LDZ >= max(1,N). X* X* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) X* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. X* X* LWORK (input) INTEGER X* The length of the array WORK. LWORK >= max(1,8*N). X* For optimal efficiency, LWORK >= (NB+3)*N, X* where NB is the blocksize for DSYTRD returned by ILAENV. X* X* IWORK (workspace) INTEGER array, dimension (5*N) X* X* IFAIL (output) INTEGER array, dimension (N) X* If JOBZ = 'V', then if INFO = 0, the first M elements of X* IFAIL are zero. If INFO > 0, then IFAIL contains the X* indices of the eigenvectors that failed to converge. X* If JOBZ = 'N', then IFAIL is not referenced. X* X* INFO (output) INTEGER X* = 0: successful exit X* < 0: if INFO = -i, the i-th argument had an illegal value X* > 0: if INFO = i, then i eigenvectors failed to converge. X* Their indices are stored in array IFAIL. X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ZERO, ONE X PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) X* .. X* .. Local Scalars .. X LOGICAL ALLEIG, INDEIG, LOWER, VALEIG, WANTZ X CHARACTER ORDER X INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, X $ INDISP, INDIWO, INDTAU, INDWKN, INDWRK, ISCALE, X $ ITMP1, J, JJ, LLWORK, LLWRKN, LOPT, NSPLIT X DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, X $ SIGMA, SMLNUM, TMP1, VLL, VUU X* .. X* .. External Functions .. X LOGICAL LSAME X DOUBLE PRECISION DLAMCH, DLANSY X EXTERNAL LSAME, DLAMCH, DLANSY X* .. X* .. External Subroutines .. X EXTERNAL DCOPY, DLACPY, DORGTR, DORMTR, DSCAL, DSTEBZ, X $ DSTEIN, DSTEQR, DSTERF, DSWAP, DSYTRD, XERBLA X* .. X* .. Intrinsic Functions .. X INTRINSIC MAX, MIN, SQRT X* .. X* .. Executable Statements .. X* X* Test the input parameters. X* X LOWER = LSAME( UPLO, 'L' ) X WANTZ = LSAME( JOBZ, 'V' ) X ALLEIG = LSAME( RANGE, 'A' ) X VALEIG = LSAME( RANGE, 'V' ) X INDEIG = LSAME( RANGE, 'I' ) X* X INFO = 0 X IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN X INFO = -1 X ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN X INFO = -2 X ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN X INFO = -3 X ELSE IF( N.LT.0 ) THEN X INFO = -4 X ELSE IF( LDA.LT.MAX( 1, N ) ) THEN X INFO = -6 X ELSE IF( VALEIG .AND. N.GT.0 .AND. VU.LE.VL ) THEN X INFO = -8 X ELSE IF( INDEIG .AND. IL.LT.1 ) THEN X INFO = -9 X ELSE IF( INDEIG .AND. ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) ) THEN X INFO = -10 X ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN X INFO = -15 X ELSE IF( LWORK.LT.MAX( 1, 8*N ) ) THEN X INFO = -17 X END IF X* X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DSYEVX', -INFO ) X RETURN X END IF X* X* Quick return if possible X* X M = 0 X IF( N.EQ.0 ) THEN X WORK( 1 ) = 1 X RETURN X END IF X* X IF( N.EQ.1 ) THEN X WORK( 1 ) = 7 X IF( ALLEIG .OR. INDEIG ) THEN X M = 1 X W( 1 ) = A( 1, 1 ) X ELSE X IF( VL.LT.A( 1, 1 ) .AND. VU.GE.A( 1, 1 ) ) THEN X M = 1 X W( 1 ) = A( 1, 1 ) X END IF X END IF X IF( WANTZ ) X $ Z( 1, 1 ) = ONE X RETURN X END IF X* X* Get machine constants. X* X SAFMIN = DLAMCH( 'Safe minimum' ) X EPS = DLAMCH( 'Precision' ) X SMLNUM = SAFMIN / EPS X BIGNUM = ONE / SMLNUM X RMIN = SQRT( SMLNUM ) X RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) X* X* Scale matrix to allowable range, if necessary. X* X ISCALE = 0 X ABSTLL = ABSTOL X IF( VALEIG ) THEN X VLL = VL X VUU = VU X END IF X ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK ) X IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN X ISCALE = 1 X SIGMA = RMIN / ANRM X ELSE IF( ANRM.GT.RMAX ) THEN X ISCALE = 1 X SIGMA = RMAX / ANRM X END IF X IF( ISCALE.EQ.1 ) THEN X IF( LOWER ) THEN X DO 10 J = 1, N X CALL DSCAL( N-J+1, SIGMA, A( J, J ), 1 ) X 10 CONTINUE X ELSE X DO 20 J = 1, N X CALL DSCAL( J, SIGMA, A( 1, J ), 1 ) X 20 CONTINUE X END IF X IF( ABSTOL.GT.0 ) X $ ABSTLL = ABSTOL*SIGMA X IF( VALEIG ) THEN X VLL = VL*SIGMA X VUU = VU*SIGMA X END IF X END IF X* X* Call DSYTRD to reduce symmetric matrix to tridiagonal form. X* X INDTAU = 1 X INDE = INDTAU + N X INDD = INDE + N X INDWRK = INDD + N X LLWORK = LWORK - INDWRK + 1 X CALL DSYTRD( UPLO, N, A, LDA, WORK( INDD ), WORK( INDE ), X $ WORK( INDTAU ), WORK( INDWRK ), LLWORK, IINFO ) X LOPT = 3*N + WORK( INDWRK ) X* X* If all eigenvalues are desired and ABSTOL is less than or equal to X* zero, then call DSTERF or DORGTR and SSTEQR. If this fails for X* some eigenvalue, then try DSTEBZ. X* X IF( ( ALLEIG .OR. ( INDEIG .AND. IL.EQ.1 .AND. IU.EQ.N ) ) .AND. X $ ( ABSTOL.LE.ZERO ) ) THEN X CALL DCOPY( N, WORK( INDD ), 1, W, 1 ) X INDEE = INDWRK + 2*N X IF( .NOT.WANTZ ) THEN X CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) X CALL DSTERF( N, W, WORK( INDEE ), INFO ) X ELSE X CALL DLACPY( 'A', N, N, A, LDA, Z, LDZ ) X CALL DORGTR( UPLO, N, Z, LDZ, WORK( INDTAU ), X $ WORK( INDWRK ), LLWORK, IINFO ) X CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) X CALL DSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ, X $ WORK( INDWRK ), INFO ) X IF( INFO.EQ.0 ) THEN X DO 30 I = 1, N X IFAIL( I ) = 0 X 30 CONTINUE X END IF X END IF X IF( INFO.EQ.0 ) THEN X M = N X GO TO 40 X END IF X INFO = 0 X END IF X* X* Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN. X* X IF( WANTZ ) THEN X ORDER = 'B' X ELSE X ORDER = 'E' X END IF X INDIBL = 1 X INDISP = INDIBL + N X INDIWO = INDISP + N X CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, X $ WORK( INDD ), WORK( INDE ), M, NSPLIT, W, X $ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ), X $ IWORK( INDIWO ), INFO ) X* X IF( WANTZ ) THEN X CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W, X $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, X $ WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO ) X* X* Apply orthogonal matrix used in reduction to tridiagonal X* form to eigenvectors returned by DSTEIN. X* X INDWKN = INDE X LLWRKN = LWORK - INDWKN + 1 X CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, X $ LDZ, WORK( INDWKN ), LLWRKN, IINFO ) X END IF X* X* If matrix was scaled, then rescale eigenvalues appropriately. X* X 40 CONTINUE X IF( ISCALE.EQ.1 ) THEN X IF( INFO.EQ.0 ) THEN X IMAX = M X ELSE X IMAX = INFO - 1 X END IF X CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) X END IF X* X* If eigenvalues are not in order, then sort them, along with X* eigenvectors. X* X IF( WANTZ ) THEN X DO 60 J = 1, M - 1 X I = 0 X TMP1 = W( J ) X DO 50 JJ = J + 1, M X IF( W( JJ ).LT.TMP1 ) THEN X I = JJ X TMP1 = W( JJ ) X END IF X 50 CONTINUE X* X IF( I.NE.0 ) THEN X ITMP1 = IWORK( INDIBL+I-1 ) X W( I ) = W( J ) X IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 ) X W( J ) = TMP1 X IWORK( INDIBL+J-1 ) = ITMP1 X CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) X IF( INFO.NE.0 ) THEN X ITMP1 = IFAIL( I ) X IFAIL( I ) = IFAIL( J ) X IFAIL( J ) = ITMP1 X END IF X END IF X 60 CONTINUE X END IF X* X* Set WORK(1) to optimal workspace size. X* X WORK( 1 ) = MAX( 7*N, LOPT ) X* X RETURN X* X* End of DSYEVX X* X END X* X SUBROUTINE DSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E, X $ M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK, X $ INFO ) X* X* -- LAPACK routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* September 30, 1994 X* X* .. Scalar Arguments .. X CHARACTER ORDER, RANGE X INTEGER IL, INFO, IU, M, N, NSPLIT X DOUBLE PRECISION ABSTOL, VL, VU X* .. X* .. Array Arguments .. X INTEGER IBLOCK( * ), ISPLIT( * ), IWORK( * ) X DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ) X* .. X* X* Purpose X* ======= X* X* DSTEBZ computes the eigenvalues of a symmetric tridiagonal X* matrix T. The user may ask for all eigenvalues, all eigenvalues X* in the half-open interval (VL, VU], or the IL-th through IU-th X* eigenvalues. X* X* To avoid overflow, the matrix must be scaled so that its X* largest element is no greater than overflow**(1/2) * X* underflow**(1/4) in absolute value, and for greatest X* accuracy, it should not be much smaller than that. X* X* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal X* Matrix", Report CS41, Computer Science Dept., Stanford X* University, July 21, 1966. X* X* Arguments X* ========= X* X* RANGE (input) CHARACTER X* = 'A': ("All") all eigenvalues will be found. X* = 'V': ("Value") all eigenvalues in the half-open interval X* (VL, VU] will be found. X* = 'I': ("Index") the IL-th through IU-th eigenvalues (of the X* entire matrix) will be found. X* X* ORDER (input) CHARACTER X* = 'B': ("By Block") the eigenvalues will be grouped by X* split-off block (see IBLOCK, ISPLIT) and X* ordered from smallest to largest within X* the block. X* = 'E': ("Entire matrix") X* the eigenvalues for the entire matrix X* will be ordered from smallest to X* largest. X* X* N (input) INTEGER X* The order of the tridiagonal matrix T. N >= 0. X* X* VL (input) DOUBLE PRECISION X* VU (input) DOUBLE PRECISION X* If RANGE='V', the lower and upper bounds of the interval to X* be searched for eigenvalues. Eigenvalues less than or equal X* to VL, or greater than VU, will not be returned. VL < VU. X* Not referenced if RANGE = 'A' or 'I'. X* X* IL (input) INTEGER X* IU (input) INTEGER X* If RANGE='I', the indices (in ascending order) of the X* smallest and largest eigenvalues to be returned. X* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. X* Not referenced if RANGE = 'A' or 'V'. X* X* ABSTOL (input) DOUBLE PRECISION X* The absolute tolerance for the eigenvalues. An eigenvalue X* (or cluster) is considered to be located if it has been X* determined to lie in an interval whose width is ABSTOL or X* less. If ABSTOL is less than or equal to zero, then ULP*|T| X* will be used, where |T| means the 1-norm of T. X* X* Eigenvalues will be computed most accurately when ABSTOL is X* set to twice the underflow threshold 2*DLAMCH('S'), not zero. X* X* D (input) DOUBLE PRECISION array, dimension (N) X* The n diagonal elements of the tridiagonal matrix T. X* X* E (input) DOUBLE PRECISION array, dimension (N-1) X* The (n-1) off-diagonal elements of the tridiagonal matrix T. X* X* M (output) INTEGER X* The actual number of eigenvalues found. 0 <= M <= N. X* (See also the description of INFO=2,3.) X* X* NSPLIT (output) INTEGER X* The number of diagonal blocks in the matrix T. X* 1 <= NSPLIT <= N. X* X* W (output) DOUBLE PRECISION array, dimension (N) X* On exit, the first M elements of W will contain the X* eigenvalues. (DSTEBZ may use the remaining N-M elements as X* workspace.) X* X* IBLOCK (output) INTEGER array, dimension (N) X* At each row/column j where E(j) is zero or small, the X* matrix T is considered to split into a block diagonal X* matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which X* block (from 1 to the number of blocks) the eigenvalue W(i) X* belongs. (DSTEBZ may use the remaining N-M elements as X* workspace.) X* X* ISPLIT (output) INTEGER array, dimension (N) X* The splitting points, at which T breaks up into submatrices. X* The first submatrix consists of rows/columns 1 to ISPLIT(1), X* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), X* etc., and the NSPLIT-th consists of rows/columns X* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. X* (Only the first NSPLIT elements will actually be used, but X* since the user cannot know a priori what value NSPLIT will X* have, N words must be reserved for ISPLIT.) X* X* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) X* X* IWORK (workspace) INTEGER array, dimension (3*N) X* X* INFO (output) INTEGER X* = 0: successful exit X* < 0: if INFO = -i, the i-th argument had an illegal value X* > 0: some or all of the eigenvalues failed to converge or X* were not computed: X* =1 or 3: Bisection failed to converge for some X* eigenvalues; these eigenvalues are flagged by a X* negative block number. The effect is that the X* eigenvalues may not be as accurate as the X* absolute and relative tolerances. This is X* generally caused by unexpectedly inaccurate X* arithmetic. X* =2 or 3: RANGE='I' only: Not all of the eigenvalues X* IL:IU were found. X* Effect: M < IU+1-IL X* Cause: non-monotonic arithmetic, causing the X* Sturm sequence to be non-monotonic. X* Cure: recalculate, using RANGE='A', and pick X* out eigenvalues IL:IU. In some cases, X* increasing the PARAMETER "FUDGE" may X* make things work. X* = 4: RANGE='I', and the Gershgorin interval X* initially used was too small. No eigenvalues X* were computed. X* Probable cause: your machine has sloppy X* floating-point arithmetic. X* Cure: Increase the PARAMETER "FUDGE", X* recompile, and try again. X* X* Internal Parameters X* =================== X* X* RELFAC DOUBLE PRECISION, default = 2.0e0 X* The relative tolerance. An interval (a,b] lies within X* "relative tolerance" if b-a < RELFAC*ulp*max(|a|,|b|), X* where "ulp" is the machine precision (distance from 1 to X* the next larger floating point number.) X* X* FUDGE DOUBLE PRECISION, default = 2 X* A "fudge factor" to widen the Gershgorin intervals. Ideally, X* a value of 1 should work, but on machines with sloppy X* arithmetic, this needs to be larger. The default for X* publicly released versions should be large enough to handle X* the worst machine around. Note that this has no effect X* on accuracy of the solution. X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ZERO, ONE, TWO, HALF X PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, X $ HALF = 1.0D0 / TWO ) X DOUBLE PRECISION FUDGE, RELFAC X PARAMETER ( FUDGE = 2.0D0, RELFAC = 2.0D0 ) X* .. X* .. Local Scalars .. X LOGICAL NCNVRG, TOOFEW X INTEGER IB, IBEGIN, IDISCL, IDISCU, IE, IEND, IINFO, X $ IM, IN, IOFF, IORDER, IOUT, IRANGE, ITMAX, X $ ITMP1, IW, IWOFF, J, JB, JDISC, JE, NB, NWL, X $ NWU X DOUBLE PRECISION ATOLI, BNORM, GL, GU, PIVMIN, RTOLI, SAFEMN, X $ TMP1, TMP2, TNORM, ULP, WKILL, WL, WLU, WU, WUL X* .. X* .. Local Arrays .. X INTEGER IDUMMA( 1 ) X* .. X* .. External Functions .. X LOGICAL LSAME X INTEGER ILAENV X DOUBLE PRECISION DLAMCH X EXTERNAL LSAME, ILAENV, DLAMCH X* .. X* .. External Subroutines .. X EXTERNAL DLAEBZ, XERBLA X* .. X* .. Intrinsic Functions .. X INTRINSIC ABS, INT, LOG, MAX, MIN, SQRT X* .. X* .. Executable Statements .. X* X INFO = 0 X* X* Decode RANGE X* X IF( LSAME( RANGE, 'A' ) ) THEN X IRANGE = 1 X ELSE IF( LSAME( RANGE, 'V' ) ) THEN X IRANGE = 2 X ELSE IF( LSAME( RANGE, 'I' ) ) THEN X IRANGE = 3 X ELSE X IRANGE = 0 X END IF X* X* Decode ORDER X* X IF( LSAME( ORDER, 'B' ) ) THEN X IORDER = 2 X ELSE IF( LSAME( ORDER, 'E' ) ) THEN X IORDER = 1 X ELSE X IORDER = 0 X END IF X* X* Check for Errors X* X IF( IRANGE.LE.0 ) THEN X INFO = -1 X ELSE IF( IORDER.LE.0 ) THEN X INFO = -2 X ELSE IF( N.LT.0 ) THEN X INFO = -3 X ELSE IF( IRANGE.EQ.2 .AND. VL.GE.VU ) THEN X INFO = -5 X ELSE IF( IRANGE.EQ.3 .AND. ( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) ) X $ THEN X INFO = -6 X ELSE IF( IRANGE.EQ.3 .AND. ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) ) X $ THEN X INFO = -7 X END IF X* X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DSTEBZ', -INFO ) X RETURN X END IF X* X* Initialize error flags X* X INFO = 0 X NCNVRG = .FALSE. X TOOFEW = .FALSE. X* X* Quick return if possible X* X M = 0 X IF( N.EQ.0 ) X $ RETURN X* X* Simplifications: X* X IF( IRANGE.EQ.3 .AND. IL.EQ.1 .AND. IU.EQ.N ) X $ IRANGE = 1 X* X* Get machine constants X* NB is the minimum vector length for vector bisection, or 0 X* if only scalar is to be done. X* X SAFEMN = DLAMCH( 'S' ) X ULP = DLAMCH( 'P' ) X RTOLI = ULP*RELFAC X NB = ILAENV( 1, 'DSTEBZ', ' ', N, -1, -1, -1 ) X IF( NB.LE.1 ) X $ NB = 0 X* X* Special Case when N=1 X* X IF( N.EQ.1 ) THEN X NSPLIT = 1 X ISPLIT( 1 ) = 1 X IF( IRANGE.EQ.2 .AND. ( VL.GE.D( 1 ) .OR. VU.LT.D( 1 ) ) ) THEN X M = 0 X ELSE X W( 1 ) = D( 1 ) X IBLOCK( 1 ) = 1 X M = 1 X END IF X RETURN X END IF X* X* Compute Splitting Points X* X NSPLIT = 1 X WORK( N ) = ZERO X PIVMIN = ONE X* X DO 10 J = 2, N X TMP1 = E( J-1 )**2 X IF( ABS( D( J )*D( J-1 ) )*ULP**2+SAFEMN.GT.TMP1 ) THEN X ISPLIT( NSPLIT ) = J - 1 X NSPLIT = NSPLIT + 1 X WORK( J-1 ) = ZERO X ELSE X WORK( J-1 ) = TMP1 X PIVMIN = MAX( PIVMIN, TMP1 ) X END IF X 10 CONTINUE X ISPLIT( NSPLIT ) = N X PIVMIN = PIVMIN*SAFEMN X* X* Compute Interval and ATOLI X* X IF( IRANGE.EQ.3 ) THEN X* X* RANGE='I': Compute the interval containing eigenvalues X* IL through IU. X* X* Compute Gershgorin interval for entire (split) matrix X* and use it as the initial interval X* X GU = D( 1 ) X GL = D( 1 ) X TMP1 = ZERO X* X DO 20 J = 1, N - 1 X TMP2 = SQRT( WORK( J ) ) X GU = MAX( GU, D( J )+TMP1+TMP2 ) X GL = MIN( GL, D( J )-TMP1-TMP2 ) X TMP1 = TMP2 X 20 CONTINUE X* X GU = MAX( GU, D( N )+TMP1 ) X GL = MIN( GL, D( N )-TMP1 ) X TNORM = MAX( ABS( GL ), ABS( GU ) ) X GL = GL - FUDGE*TNORM*ULP*N - FUDGE*TWO*PIVMIN X GU = GU + FUDGE*TNORM*ULP*N + FUDGE*PIVMIN X* X* Compute Iteration parameters X* X ITMAX = INT( ( LOG( TNORM+PIVMIN )-LOG( PIVMIN ) ) / X $ LOG( TWO ) ) + 2 X IF( ABSTOL.LE.ZERO ) THEN X ATOLI = ULP*TNORM X ELSE X ATOLI = ABSTOL X END IF X* X WORK( N+1 ) = GL X WORK( N+2 ) = GL X WORK( N+3 ) = GU X WORK( N+4 ) = GU X WORK( N+5 ) = GL X WORK( N+6 ) = GU X IWORK( 1 ) = -1 X IWORK( 2 ) = -1 X IWORK( 3 ) = N + 1 X IWORK( 4 ) = N + 1 X IWORK( 5 ) = IL - 1 X IWORK( 6 ) = IU X* X CALL DLAEBZ( 3, ITMAX, N, 2, 2, NB, ATOLI, RTOLI, PIVMIN, D, E, X $ WORK, IWORK( 5 ), WORK( N+1 ), WORK( N+5 ), IOUT, X $ IWORK, W, IBLOCK, IINFO ) X* X IF( IWORK( 6 ).EQ.IU ) THEN X WL = WORK( N+1 ) X WLU = WORK( N+3 ) X NWL = IWORK( 1 ) X WU = WORK( N+4 ) X WUL = WORK( N+2 ) X NWU = IWORK( 4 ) X ELSE X WL = WORK( N+2 ) X WLU = WORK( N+4 ) X NWL = IWORK( 2 ) X WU = WORK( N+3 ) X WUL = WORK( N+1 ) X NWU = IWORK( 3 ) X END IF X* X IF( NWL.LT.0 .OR. NWL.GE.N .OR. NWU.LT.1 .OR. NWU.GT.N ) THEN X INFO = 4 X RETURN X END IF X ELSE X* X* RANGE='A' or 'V' -- Set ATOLI X* X TNORM = MAX( ABS( D( 1 ) )+ABS( E( 1 ) ), X $ ABS( D( N ) )+ABS( E( N-1 ) ) ) X* X DO 30 J = 2, N - 1 X TNORM = MAX( TNORM, ABS( D( J ) )+ABS( E( J-1 ) )+ X $ ABS( E( J ) ) ) X 30 CONTINUE X* X IF( ABSTOL.LE.ZERO ) THEN X ATOLI = ULP*TNORM X ELSE X ATOLI = ABSTOL X END IF X* X IF( IRANGE.EQ.2 ) THEN X WL = VL X WU = VU X END IF X END IF X* X* Find Eigenvalues -- Loop Over Blocks and recompute NWL and NWU. X* NWL accumulates the number of eigenvalues .le. WL, X* NWU accumulates the number of eigenvalues .le. WU X* X M = 0 X IEND = 0 X INFO = 0 X NWL = 0 X NWU = 0 X* X DO 70 JB = 1, NSPLIT X IOFF = IEND X IBEGIN = IOFF + 1 X IEND = ISPLIT( JB ) X IN = IEND - IOFF X* X IF( IN.EQ.1 ) THEN X* X* Special Case -- IN=1 X* X IF( IRANGE.EQ.1 .OR. WL.GE.D( IBEGIN )-PIVMIN ) X $ NWL = NWL + 1 X IF( IRANGE.EQ.1 .OR. WU.GE.D( IBEGIN )-PIVMIN ) X $ NWU = NWU + 1 X IF( IRANGE.EQ.1 .OR. ( WL.LT.D( IBEGIN )-PIVMIN .AND. WU.GE. X $ D( IBEGIN )-PIVMIN ) ) THEN X M = M + 1 X W( M ) = D( IBEGIN ) X IBLOCK( M ) = JB X END IF X ELSE X* X* General Case -- IN > 1 X* X* Compute Gershgorin Interval X* and use it as the initial interval X* X GU = D( IBEGIN ) X GL = D( IBEGIN ) X TMP1 = ZERO X* X DO 40 J = IBEGIN, IEND - 1 X TMP2 = ABS( E( J ) ) X GU = MAX( GU, D( J )+TMP1+TMP2 ) X GL = MIN( GL, D( J )-TMP1-TMP2 ) X TMP1 = TMP2 X 40 CONTINUE X* X GU = MAX( GU, D( IEND )+TMP1 ) X GL = MIN( GL, D( IEND )-TMP1 ) X BNORM = MAX( ABS( GL ), ABS( GU ) ) X GL = GL - FUDGE*BNORM*ULP*IN - FUDGE*PIVMIN X GU = GU + FUDGE*BNORM*ULP*IN + FUDGE*PIVMIN X* X* Compute ATOLI for the current submatrix X* X IF( ABSTOL.LE.ZERO ) THEN X ATOLI = ULP*MAX( ABS( GL ), ABS( GU ) ) X ELSE X ATOLI = ABSTOL X END IF X* X IF( IRANGE.GT.1 ) THEN X IF( GU.LT.WL ) THEN X NWL = NWL + IN X NWU = NWU + IN X GO TO 70 X END IF X GL = MAX( GL, WL ) X GU = MIN( GU, WU ) X IF( GL.GE.GU ) X $ GO TO 70 X END IF X* X* Set Up Initial Interval X* X WORK( N+1 ) = GL X WORK( N+IN+1 ) = GU X CALL DLAEBZ( 1, 0, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN, X $ D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ), X $ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IM, X $ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO ) X* X NWL = NWL + IWORK( 1 ) X NWU = NWU + IWORK( IN+1 ) X IWOFF = M - IWORK( 1 ) X* X* Compute Eigenvalues X* X ITMAX = INT( ( LOG( GU-GL+PIVMIN )-LOG( PIVMIN ) ) / X $ LOG( TWO ) ) + 2 X CALL DLAEBZ( 2, ITMAX, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN, X $ D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ), X $ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IOUT, X $ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO ) X* X* Copy Eigenvalues Into W and IBLOCK X* Use -JB for block number for unconverged eigenvalues. X* X DO 60 J = 1, IOUT X TMP1 = HALF*( WORK( J+N )+WORK( J+IN+N ) ) X* X* Flag non-convergence. X* X IF( J.GT.IOUT-IINFO ) THEN X NCNVRG = .TRUE. X IB = -JB X ELSE X IB = JB X END IF X DO 50 JE = IWORK( J ) + 1 + IWOFF, X $ IWORK( J+IN ) + IWOFF X W( JE ) = TMP1 X IBLOCK( JE ) = IB X 50 CONTINUE X 60 CONTINUE X* X M = M + IM X END IF X 70 CONTINUE X* X* If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU X* If NWL+1 < IL or NWU > IU, discard extra eigenvalues. X* X IF( IRANGE.EQ.3 ) THEN X IM = 0 X IDISCL = IL - 1 - NWL X IDISCU = NWU - IU X* X IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN X DO 80 JE = 1, M X IF( W( JE ).LE.WLU .AND. IDISCL.GT.0 ) THEN X IDISCL = IDISCL - 1 X ELSE IF( W( JE ).GE.WUL .AND. IDISCU.GT.0 ) THEN X IDISCU = IDISCU - 1 X ELSE X IM = IM + 1 X W( IM ) = W( JE ) X IBLOCK( IM ) = IBLOCK( JE ) X END IF X 80 CONTINUE X M = IM X END IF X IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN X* X* Code to deal with effects of bad arithmetic: X* Some low eigenvalues to be discarded are not in (WL,WLU], X* or high eigenvalues to be discarded are not in (WUL,WU] X* so just kill off the smallest IDISCL/largest IDISCU X* eigenvalues, by simply finding the smallest/largest X* eigenvalue(s). X* X* (If N(w) is monotone non-decreasing, this should never X* happen.) X* X IF( IDISCL.GT.0 ) THEN X WKILL = WU X DO 100 JDISC = 1, IDISCL X IW = 0 X DO 90 JE = 1, M X IF( IBLOCK( JE ).NE.0 .AND. X $ ( W( JE ).LT.WKILL .OR. IW.EQ.0 ) ) THEN X IW = JE X WKILL = W( JE ) X END IF X 90 CONTINUE X IBLOCK( IW ) = 0 X 100 CONTINUE X END IF X IF( IDISCU.GT.0 ) THEN X* X WKILL = WL X DO 120 JDISC = 1, IDISCU X IW = 0 X DO 110 JE = 1, M X IF( IBLOCK( JE ).NE.0 .AND. X $ ( W( JE ).GT.WKILL .OR. IW.EQ.0 ) ) THEN X IW = JE X WKILL = W( JE ) X END IF X 110 CONTINUE X IBLOCK( IW ) = 0 X 120 CONTINUE X END IF X IM = 0 X DO 130 JE = 1, M X IF( IBLOCK( JE ).NE.0 ) THEN X IM = IM + 1 X W( IM ) = W( JE ) X IBLOCK( IM ) = IBLOCK( JE ) X END IF X 130 CONTINUE X M = IM X END IF X IF( IDISCL.LT.0 .OR. IDISCU.LT.0 ) THEN X TOOFEW = .TRUE. X END IF X END IF X* X* If ORDER='B', do nothing -- the eigenvalues are already sorted X* by block. X* If ORDER='E', sort the eigenvalues from smallest to largest X* X IF( IORDER.EQ.1 .AND. NSPLIT.GT.1 ) THEN X DO 150 JE = 1, M - 1 X IE = 0 X TMP1 = W( JE ) X DO 140 J = JE + 1, M X IF( W( J ).LT.TMP1 ) THEN X IE = J X TMP1 = W( J ) X END IF X 140 CONTINUE X* X IF( IE.NE.0 ) THEN X ITMP1 = IBLOCK( IE ) X W( IE ) = W( JE ) X IBLOCK( IE ) = IBLOCK( JE ) X W( JE ) = TMP1 X IBLOCK( JE ) = ITMP1 X END IF X 150 CONTINUE X END IF X* X INFO = 0 X IF( NCNVRG ) X $ INFO = INFO + 1 X IF( TOOFEW ) X $ INFO = INFO + 2 X RETURN X* X* End of DSTEBZ X* X END X SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) X* X* -- LAPACK routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* March 31, 1993 X* X* .. Scalar Arguments .. X CHARACTER TRANS X INTEGER INFO, LDA, LDB, N, NRHS X* .. X* .. Array Arguments .. X INTEGER IPIV( * ) X DOUBLE PRECISION A( LDA, * ), B( LDB, * ) X* .. X* X* Purpose X* ======= X* X* DGETRS solves a system of linear equations X* A * X = B or A' * X = B X* with a general N-by-N matrix A using the LU factorization computed X* by DGETRF. X* X* Arguments X* ========= X* X* TRANS (input) CHARACTER*1 X* Specifies the form of the system of equations: X* = 'N': A * X = B (No transpose) X* = 'T': A'* X = B (Transpose) X* = 'C': A'* X = B (Conjugate transpose = Transpose) X* X* N (input) INTEGER X* The order of the matrix A. N >= 0. X* X* NRHS (input) INTEGER X* The number of right hand sides, i.e., the number of columns X* of the matrix B. NRHS >= 0. X* X* A (input) DOUBLE PRECISION array, dimension (LDA,N) X* The factors L and U from the factorization A = P*L*U X* as computed by DGETRF. X* X* LDA (input) INTEGER X* The leading dimension of the array A. LDA >= max(1,N). X* X* IPIV (input) INTEGER array, dimension (N) X* The pivot indices from DGETRF; for 1<=i<=N, row i of the X* matrix was interchanged with row IPIV(i). X* X* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) X* On entry, the right hand side matrix B. X* On exit, the solution matrix X. X* X* LDB (input) INTEGER X* The leading dimension of the array B. LDB >= max(1,N). X* X* INFO (output) INTEGER X* = 0: successful exit X* < 0: if INFO = -i, the i-th argument had an illegal value X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ONE X PARAMETER ( ONE = 1.0D+0 ) X* .. X* .. Local Scalars .. X LOGICAL NOTRAN X* .. X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. X* .. External Subroutines .. X EXTERNAL DLASWP, DTRSM, XERBLA X* .. X* .. Intrinsic Functions .. X INTRINSIC MAX X* .. X* .. Executable Statements .. X* X* Test the input parameters. X* X INFO = 0 X NOTRAN = LSAME( TRANS, 'N' ) X IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. X $ LSAME( TRANS, 'C' ) ) THEN X INFO = -1 X ELSE IF( N.LT.0 ) THEN X INFO = -2 X ELSE IF( NRHS.LT.0 ) THEN X INFO = -3 X ELSE IF( LDA.LT.MAX( 1, N ) ) THEN X INFO = -5 X ELSE IF( LDB.LT.MAX( 1, N ) ) THEN X INFO = -8 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DGETRS', -INFO ) X RETURN X END IF X* X* Quick return if possible X* X IF( N.EQ.0 .OR. NRHS.EQ.0 ) X $ RETURN X* X IF( NOTRAN ) THEN X* X* Solve A * X = B. X* X* Apply row interchanges to the right hand sides. X* X CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, 1 ) X* X* Solve L*X = B, overwriting B with X. X* X CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS, X $ ONE, A, LDA, B, LDB ) X* X* Solve U*X = B, overwriting B with X. X* X CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, X $ NRHS, ONE, A, LDA, B, LDB ) X ELSE X* X* Solve A' * X = B. X* X* Solve U'*X = B, overwriting B with X. X* X CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, X $ ONE, A, LDA, B, LDB ) X* X* Solve L'*X = B, overwriting B with X. X* X CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE, X $ A, LDA, B, LDB ) X* X* Apply row interchanges to the solution vectors. X* X CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, -1 ) X END IF X* X RETURN X* X* End of DGETRS X* X END X SUBROUTINE DORMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, X $ WORK, LWORK, INFO ) X* X* -- LAPACK routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* September 30, 1994 X* X* .. Scalar Arguments .. X CHARACTER SIDE, TRANS, UPLO X INTEGER INFO, LDA, LDC, LWORK, M, N X* .. X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), X $ WORK( LWORK ) X* .. X* X* Purpose X* ======= X* X* DORMTR overwrites the general real M-by-N matrix C with X* X* SIDE = 'L' SIDE = 'R' X* TRANS = 'N': Q * C C * Q X* TRANS = 'T': Q**T * C C * Q**T X* X* where Q is a real orthogonal matrix of order nq, with nq = m if X* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of X* nq-1 elementary reflectors, as returned by DSYTRD: X* X* if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); X* X* if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). X* X* Arguments X* ========= X* X* SIDE (input) CHARACTER*1 X* = 'L': apply Q or Q**T from the Left; X* = 'R': apply Q or Q**T from the Right. X* X* UPLO (input) CHARACTER*1 X* = 'U': Upper triangle of A contains elementary reflectors X* from DSYTRD; X* = 'L': Lower triangle of A contains elementary reflectors X* from DSYTRD. X* X* TRANS (input) CHARACTER*1 X* = 'N': No transpose, apply Q; X* = 'T': Transpose, apply Q**T. X* X* M (input) INTEGER X* The number of rows of the matrix C. M >= 0. X* X* N (input) INTEGER X* The number of columns of the matrix C. N >= 0. X* X* A (input) DOUBLE PRECISION array, dimension X* (LDA,M) if SIDE = 'L' X* (LDA,N) if SIDE = 'R' X* The vectors which define the elementary reflectors, as X* returned by DSYTRD. X* X* LDA (input) INTEGER X* The leading dimension of the array A. X* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. X* X* TAU (input) DOUBLE PRECISION array, dimension X* (M-1) if SIDE = 'L' X* (N-1) if SIDE = 'R' X* TAU(i) must contain the scalar factor of the elementary X* reflector H(i), as returned by DSYTRD. X* X* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) X* On entry, the M-by-N matrix C. X* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. X* X* LDC (input) INTEGER X* The leading dimension of the array C. LDC >= max(1,M). X* X* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) X* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. X* X* LWORK (input) INTEGER X* The dimension of the array WORK. X* If SIDE = 'L', LWORK >= max(1,N); X* if SIDE = 'R', LWORK >= max(1,M). X* For optimum performance LWORK >= N*NB if SIDE = 'L', and X* LWORK >= M*NB if SIDE = 'R', where NB is the optimal X* blocksize. X* X* INFO (output) INTEGER X* = 0: successful exit X* < 0: if INFO = -i, the i-th argument had an illegal value X* X* ===================================================================== X* X* .. Local Scalars .. X LOGICAL LEFT, UPPER X INTEGER I1, I2, IINFO, MI, NI, NQ, NW X* .. X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. X* .. External Subroutines .. X EXTERNAL DORMQL, DORMQR, XERBLA X* .. X* .. Intrinsic Functions .. X INTRINSIC MAX X* .. X* .. Executable Statements .. X* X* Test the input arguments X* X INFO = 0 X LEFT = LSAME( SIDE, 'L' ) X UPPER = LSAME( UPLO, 'U' ) X* X* NQ is the order of Q and NW is the minimum dimension of WORK X* X IF( LEFT ) THEN X NQ = M X NW = N X ELSE X NQ = N X NW = M X END IF X IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN X INFO = -1 X ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN X INFO = -2 X ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'T' ) ) X $ THEN X INFO = -3 X ELSE IF( M.LT.0 ) THEN X INFO = -4 X ELSE IF( N.LT.0 ) THEN X INFO = -5 X ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN X INFO = -7 X ELSE IF( LDC.LT.MAX( 1, M ) ) THEN X INFO = -10 X ELSE IF( LWORK.LT.MAX( 1, NW ) ) THEN X INFO = -12 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DORMTR', -INFO ) X RETURN X END IF X* X* Quick return if possible X* X IF( M.EQ.0 .OR. N.EQ.0 .OR. NQ.EQ.1 ) THEN X WORK( 1 ) = 1 X RETURN X END IF X* X IF( LEFT ) THEN X MI = M - 1 X NI = N X ELSE X MI = M X NI = N - 1 X END IF X* X IF( UPPER ) THEN X* X* Q was determined by a call to DSYTRD with UPLO = 'U' X* X CALL DORMQL( SIDE, TRANS, MI, NI, NQ-1, A( 1, 2 ), LDA, TAU, C, X $ LDC, WORK, LWORK, IINFO ) X ELSE X* X* Q was determined by a call to DSYTRD with UPLO = 'L' X* X IF( LEFT ) THEN X I1 = 2 X I2 = 1 X ELSE X I1 = 1 X I2 = 2 X END IF X CALL DORMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU, X $ C( I1, I2 ), LDC, WORK, LWORK, IINFO ) X END IF X RETURN X* X* End of DORMTR X* X END X SUBROUTINE DGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO ) X* X* -- LAPACK driver routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* March 31, 1993 X* X* .. Scalar Arguments .. X INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS X* .. X* .. Array Arguments .. X INTEGER IPIV( * ) X DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ) X* .. X* X* Purpose X* ======= X* X* DGBSV computes the solution to a real system of linear equations X* A * X = B, where A is a band matrix of order N with KL subdiagonals X* and KU superdiagonals, and X and B are N-by-NRHS matrices. X* X* The LU decomposition with partial pivoting and row interchanges is X* used to factor A as A = L * U, where L is a product of permutation X* and unit lower triangular matrices with KL subdiagonals, and U is X* upper triangular with KL+KU superdiagonals. The factored form of A X* is then used to solve the system of equations A * X = B. X* X* Arguments X* ========= X* X* N (input) INTEGER X* The number of linear equations, i.e., the order of the X* matrix A. N >= 0. X* X* KL (input) INTEGER X* The number of subdiagonals within the band of A. KL >= 0. X* X* KU (input) INTEGER X* The number of superdiagonals within the band of A. KU >= 0. X* X* NRHS (input) INTEGER X* The number of right hand sides, i.e., the number of columns X* of the matrix B. NRHS >= 0. X* X* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) X* On entry, the matrix A in band storage, in rows KL+1 to X* 2*KL+KU+1; rows 1 to KL of the array need not be set. X* The j-th column of A is stored in the j-th column of the X* array AB as follows: X* AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL) X* On exit, details of the factorization: U is stored as an X* upper triangular band matrix with KL+KU superdiagonals in X* rows 1 to KL+KU+1, and the multipliers used during the X* factorization are stored in rows KL+KU+2 to 2*KL+KU+1. X* See below for further details. X* X* LDAB (input) INTEGER X* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. X* X* IPIV (output) INTEGER array, dimension (N) X* The pivot indices that define the permutation matrix P; X* row i of the matrix was interchanged with row IPIV(i). X* X* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) X* On entry, the N-by-NRHS right hand side matrix B. X* On exit, if INFO = 0, the N-by-NRHS solution matrix X. X* X* LDB (input) INTEGER X* The leading dimension of the array B. LDB >= max(1,N). X* X* INFO (output) INTEGER X* = 0: successful exit X* < 0: if INFO = -i, the i-th argument had an illegal value X* > 0: if INFO = i, U(i,i) is exactly zero. The factorization X* has been completed, but the factor U is exactly X* singular, and the solution has not been computed. X* X* Further Details X* =============== X* X* The band storage scheme is illustrated by the following example, when X* M = N = 6, KL = 2, KU = 1: X* X* On entry: On exit: X* X* * * * + + + * * * u14 u25 u36 X* * * + + + + * * u13 u24 u35 u46 X* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 X* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 X* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * X* a31 a42 a53 a64 * * m31 m42 m53 m64 * * X* X* Array elements marked * are not used by the routine; elements marked X* + need not be set on entry, but are required by the routine to store X* elements of U because of fill-in resulting from the row interchanges. X* X* ===================================================================== X* X* .. External Subroutines .. X EXTERNAL DGBTRF, DGBTRS, XERBLA X* .. X* .. Intrinsic Functions .. X INTRINSIC MAX X* .. X* .. Executable Statements .. X* X* Test the input parameters. X* X INFO = 0 X IF( N.LT.0 ) THEN X INFO = -1 X ELSE IF( KL.LT.0 ) THEN X INFO = -2 X ELSE IF( KU.LT.0 ) THEN X INFO = -3 X ELSE IF( NRHS.LT.0 ) THEN X INFO = -4 X ELSE IF( LDAB.LT.2*KL+KU+1 ) THEN X INFO = -6 X ELSE IF( LDB.LT.MAX( N, 1 ) ) THEN X INFO = -9 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DGBSV ', -INFO ) X RETURN X END IF X* X* Compute the LU factorization of the band matrix A. X* X CALL DGBTRF( N, N, KL, KU, AB, LDAB, IPIV, INFO ) X IF( INFO.EQ.0 ) THEN X* X* Solve the system A*X = B, overwriting B with X. X* X CALL DGBTRS( 'No transpose', N, KL, KU, NRHS, AB, LDAB, IPIV, X $ B, LDB, INFO ) X END IF X RETURN X* X* End of DGBSV X* X END X* X DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK ) X* X* -- LAPACK auxiliary routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* October 31, 1992 X* X* .. Scalar Arguments .. X CHARACTER NORM, UPLO X INTEGER LDA, N X* .. X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), WORK( * ) X* .. X* X* Purpose X* ======= X* X* DLANSY returns the value of the one norm, or the Frobenius norm, or X* the infinity norm, or the element of largest absolute value of a X* real symmetric matrix A. X* X* Description X* =========== X* X* DLANSY returns the value X* X* DLANSY = ( max(abs(A(i,j))), NORM = 'M' or 'm' X* ( X* ( norm1(A), NORM = '1', 'O' or 'o' X* ( X* ( normI(A), NORM = 'I' or 'i' X* ( X* ( normF(A), NORM = 'F', 'f', 'E' or 'e' X* X* where norm1 denotes the one norm of a matrix (maximum column sum), X* normI denotes the infinity norm of a matrix (maximum row sum) and X* normF denotes the Frobenius norm of a matrix (square root of sum of X* squares). Note that max(abs(A(i,j))) is not a matrix norm. X* X* Arguments X* ========= X* X* NORM (input) CHARACTER*1 X* Specifies the value to be returned in DLANSY as described X* above. X* X* UPLO (input) CHARACTER*1 X* Specifies whether the upper or lower triangular part of the X* symmetric matrix A is to be referenced. X* = 'U': Upper triangular part of A is referenced X* = 'L': Lower triangular part of A is referenced X* X* N (input) INTEGER X* The order of the matrix A. N >= 0. When N = 0, DLANSY is X* set to zero. X* X* A (input) DOUBLE PRECISION array, dimension (LDA,N) X* The symmetric matrix A. If UPLO = 'U', the leading n by n X* upper triangular part of A contains the upper triangular part X* of the matrix A, and the strictly lower triangular part of A X* is not referenced. If UPLO = 'L', the leading n by n lower X* triangular part of A contains the lower triangular part of X* the matrix A, and the strictly upper triangular part of A is X* not referenced. X* X* LDA (input) INTEGER X* The leading dimension of the array A. LDA >= max(N,1). X* X* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), X* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, X* WORK is not referenced. X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ONE, ZERO X PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) X* .. X* .. Local Scalars .. X INTEGER I, J X DOUBLE PRECISION ABSA, SCALE, SUM, VALUE X* .. X* .. External Subroutines .. X EXTERNAL DLASSQ X* .. X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. X* .. Intrinsic Functions .. X INTRINSIC ABS, MAX, SQRT X* .. X* .. Executable Statements .. X* X IF( N.EQ.0 ) THEN X VALUE = ZERO X ELSE IF( LSAME( NORM, 'M' ) ) THEN X* X* Find max(abs(A(i,j))). X* X VALUE = ZERO X IF( LSAME( UPLO, 'U' ) ) THEN X DO 20 J = 1, N X DO 10 I = 1, J X VALUE = MAX( VALUE, ABS( A( I, J ) ) ) X 10 CONTINUE X 20 CONTINUE X ELSE X DO 40 J = 1, N X DO 30 I = J, N X VALUE = MAX( VALUE, ABS( A( I, J ) ) ) X 30 CONTINUE X 40 CONTINUE X END IF X ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. X $ ( NORM.EQ.'1' ) ) THEN X* X* Find normI(A) ( = norm1(A), since A is symmetric). X* X VALUE = ZERO X IF( LSAME( UPLO, 'U' ) ) THEN X DO 60 J = 1, N X SUM = ZERO X DO 50 I = 1, J - 1 X ABSA = ABS( A( I, J ) ) X SUM = SUM + ABSA X WORK( I ) = WORK( I ) + ABSA X 50 CONTINUE X WORK( J ) = SUM + ABS( A( J, J ) ) X 60 CONTINUE X DO 70 I = 1, N X VALUE = MAX( VALUE, WORK( I ) ) X 70 CONTINUE X ELSE X DO 80 I = 1, N X WORK( I ) = ZERO X 80 CONTINUE X DO 100 J = 1, N X SUM = WORK( J ) + ABS( A( J, J ) ) X DO 90 I = J + 1, N X ABSA = ABS( A( I, J ) ) X SUM = SUM + ABSA X WORK( I ) = WORK( I ) + ABSA X 90 CONTINUE X VALUE = MAX( VALUE, SUM ) X 100 CONTINUE X END IF X ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN X* X* Find normF(A). X* X SCALE = ZERO X SUM = ONE X IF( LSAME( UPLO, 'U' ) ) THEN X DO 110 J = 2, N X CALL DLASSQ( J-1, A( 1, J ), 1, SCALE, SUM ) X 110 CONTINUE X ELSE X DO 120 J = 1, N - 1 X CALL DLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM ) X 120 CONTINUE X END IF X SUM = 2*SUM X CALL DLASSQ( N, A, LDA+1, SCALE, SUM ) X VALUE = SCALE*SQRT( SUM ) X END IF X* X DLANSY = VALUE X RETURN X* X* End of DLANSY X* X END X SUBROUTINE XERBLA( SRNAME, INFO ) X* X* -- LAPACK auxiliary routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* September 30, 1994 X* X* .. Scalar Arguments .. X CHARACTER*6 SRNAME X INTEGER INFO X* .. X* X* Purpose X* ======= X* X* XERBLA is an error handler for the LAPACK routines. X* It is called by an LAPACK routine if an input parameter has an X* invalid value. A message is printed and execution stops. X* X* Installers may consider modifying the STOP statement in order to X* call system-specific exception-handling facilities. X* X* Arguments X* ========= X* X* SRNAME (input) CHARACTER*6 X* The name of the routine which called XERBLA. X* X* INFO (input) INTEGER X* The position of the invalid parameter in the parameter list X* of the calling routine. X* X* ===================================================================== X* X* .. Executable Statements .. X* X WRITE( *, FMT = 9999 )SRNAME, INFO X* X STOP X* X 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ', X $ 'an illegal value' ) X* X* End of XERBLA X* X END X SUBROUTINE DGTSV( N, NRHS, DL, D, DU, B, LDB, INFO ) X* X* -- LAPACK routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* September 30, 1994 X* X* .. Scalar Arguments .. X INTEGER INFO, LDB, N, NRHS X* .. X* .. Array Arguments .. X DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ) X* .. X* X* Purpose X* ======= X* X* DGTSV solves the equation X* X* A*X = B, X* X* where A is an N-by-N tridiagonal matrix, by Gaussian elimination with X* partial pivoting. X* X* Note that the equation A'*X = B may be solved by interchanging the X* order of the arguments DU and DL. X* X* Arguments X* ========= X* X* N (input) INTEGER X* The order of the matrix A. N >= 0. X* X* NRHS (input) INTEGER X* The number of right hand sides, i.e., the number of columns X* of the matrix B. NRHS >= 0. X* X* DL (input/output) DOUBLE PRECISION array, dimension (N-1) X* On entry, DL must contain the (n-1) subdiagonal elements of X* A. X* On exit, DL is overwritten by the (n-2) elements of the X* second superdiagonal of the upper triangular matrix U from X* the LU factorization of A, in DL(1), ..., DL(n-2). X* X* D (input/output) DOUBLE PRECISION array, dimension (N) X* On entry, D must contain the diagonal elements of A. X* On exit, D is overwritten by the n diagonal elements of U. X* X* DU (input/output) DOUBLE PRECISION array, dimension (N-1) X* On entry, DU must contain the (n-1) superdiagonal elements X* of A. X* On exit, DU is overwritten by the (n-1) elements of the first X* superdiagonal of U. X* X* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) X* On entry, the N-by-NRHS right hand side matrix B. X* On exit, if INFO = 0, the N-by-NRHS solution matrix X. X* X* LDB (input) INTEGER X* The leading dimension of the array B. LDB >= max(1,N). X* X* INFO (output) INTEGER X* = 0: successful exit X* < 0: if INFO = -i, the i-th argument had an illegal value X* > 0: if INFO = i, U(i,i) is exactly zero, and the solution X* has not been computed. The factorization has not been X* completed unless i = N. X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ZERO X PARAMETER ( ZERO = 0.0D+0 ) X* .. X* .. Local Scalars .. X INTEGER J, K X DOUBLE PRECISION MULT, TEMP X* .. X* .. Intrinsic Functions .. X INTRINSIC ABS, MAX X* .. X* .. External Subroutines .. X EXTERNAL XERBLA X* .. X* .. Executable Statements .. X* X INFO = 0 X IF( N.LT.0 ) THEN X INFO = -1 X ELSE IF( NRHS.LT.0 ) THEN X INFO = -2 X ELSE IF( LDB.LT.MAX( 1, N ) ) THEN X INFO = -7 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DGTSV ', -INFO ) X RETURN X END IF X* X IF( N.EQ.0 ) X $ RETURN X* X DO 30 K = 1, N - 1 X IF( DL( K ).EQ.ZERO ) THEN X* X* Subdiagonal is zero, no elimination is required. X* X IF( D( K ).EQ.ZERO ) THEN X* X* Diagonal is zero: set INFO = K and return; a unique X* solution can not be found. X* X INFO = K X RETURN X END IF X ELSE IF( ABS( D( K ) ).GE.ABS( DL( K ) ) ) THEN X* X* No row interchange required X* X MULT = DL( K ) / D( K ) X D( K+1 ) = D( K+1 ) - MULT*DU( K ) X DO 10 J = 1, NRHS X B( K+1, J ) = B( K+1, J ) - MULT*B( K, J ) X 10 CONTINUE X IF( K.LT.( N-1 ) ) X $ DL( K ) = ZERO X ELSE X* X* Interchange rows K and K+1 X* X MULT = D( K ) / DL( K ) X D( K ) = DL( K ) X TEMP = D( K+1 ) X D( K+1 ) = DU( K ) - MULT*TEMP X IF( K.LT.( N-1 ) ) THEN X DL( K ) = DU( K+1 ) X DU( K+1 ) = -MULT*DL( K ) X END IF X DU( K ) = TEMP X DO 20 J = 1, NRHS X TEMP = B( K, J ) X B( K, J ) = B( K+1, J ) X B( K+1, J ) = TEMP - MULT*B( K+1, J ) X 20 CONTINUE X END IF X 30 CONTINUE X IF( D( N ).EQ.ZERO ) THEN X INFO = N X RETURN X END IF X* X* Back solve with the matrix U from the factorization. X* X DO 50 J = 1, NRHS X B( N, J ) = B( N, J ) / D( N ) X IF( N.GT.1 ) X $ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / D( N-1 ) X DO 40 K = N - 2, 1, -1 X B( K, J ) = ( B( K, J )-DU( K )*B( K+1, J )-DL( K )* X $ B( K+2, J ) ) / D( K ) X 40 CONTINUE X 50 CONTINUE X* X RETURN X* X* End of DGTSV X* X END X* X LOGICAL FUNCTION LSAME( CA, CB ) X* X* -- LAPACK auxiliary routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* September 30, 1994 X* X* .. Scalar Arguments .. X CHARACTER CA, CB X* .. X* X* Purpose X* ======= X* X* LSAME returns .TRUE. if CA is the same letter as CB regardless of X* case. X* X* Arguments X* ========= X* X* CA (input) CHARACTER*1 X* CB (input) CHARACTER*1 X* CA and CB specify the single characters to be compared. X* X* ===================================================================== X* X* .. Intrinsic Functions .. X INTRINSIC ICHAR X* .. X* .. Local Scalars .. X INTEGER INTA, INTB, ZCODE X* .. X* .. Executable Statements .. X* X* Test if the characters are equal X* X LSAME = CA.EQ.CB X IF( LSAME ) X $ RETURN X* X* Now test for equivalence if both characters are alphabetic. X* X ZCODE = ICHAR( 'Z' ) X* X* Use 'Z' rather than 'A' so that ASCII can be detected on Prime X* machines, on which ICHAR returns a value with bit 8 set. X* ICHAR('A') on Prime machines returns 193 which is the same as X* ICHAR('A') on an EBCDIC machine. X* X INTA = ICHAR( CA ) X INTB = ICHAR( CB ) X* X IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN X* X* ASCII is assumed - ZCODE is the ASCII code of either lower or X* upper case 'Z'. X* X IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32 X IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32 X* X ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN X* X* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or X* upper case 'Z'. X* X IF( INTA.GE.129 .AND. INTA.LE.137 .OR. X $ INTA.GE.145 .AND. INTA.LE.153 .OR. X $ INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64 X IF( INTB.GE.129 .AND. INTB.LE.137 .OR. X $ INTB.GE.145 .AND. INTB.LE.153 .OR. X $ INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64 X* X ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN X* X* ASCII is assumed, on Prime machines - ZCODE is the ASCII code X* plus 128 of either lower or upper case 'Z'. X* X IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32 X IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32 X END IF X LSAME = INTA.EQ.INTB X* X* RETURN X* X* End of LSAME X* X END X SUBROUTINE DSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) X* X* -- LAPACK routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* September 30, 1994 X* X* .. Scalar Arguments .. X CHARACTER UPLO X INTEGER INFO, LDA, LWORK, N X* .. X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ), X $ WORK( * ) X* .. X* X* Purpose X* ======= X* X* DSYTRD reduces a real symmetric matrix A to real symmetric X* tridiagonal form T by an orthogonal similarity transformation: X* Q**T * A * Q = T. X* X* Arguments X* ========= X* X* UPLO (input) CHARACTER*1 X* = 'U': Upper triangle of A is stored; X* = 'L': Lower triangle of A is stored. X* X* N (input) INTEGER X* The order of the matrix A. N >= 0. X* X* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) X* On entry, the symmetric matrix A. If UPLO = 'U', the leading X* N-by-N upper triangular part of A contains the upper X* triangular part of the matrix A, and the strictly lower X* triangular part of A is not referenced. If UPLO = 'L', the X* leading N-by-N lower triangular part of A contains the lower X* triangular part of the matrix A, and the strictly upper X* triangular part of A is not referenced. X* On exit, if UPLO = 'U', the diagonal and first superdiagonal X* of A are overwritten by the corresponding elements of the X* tridiagonal matrix T, and the elements above the first X* superdiagonal, with the array TAU, represent the orthogonal X* matrix Q as a product of elementary reflectors; if UPLO X* = 'L', the diagonal and first subdiagonal of A are over- X* written by the corresponding elements of the tridiagonal X* matrix T, and the elements below the first subdiagonal, with X* the array TAU, represent the orthogonal matrix Q as a product X* of elementary reflectors. See Further Details. X* X* LDA (input) INTEGER X* The leading dimension of the array A. LDA >= max(1,N). X* X* D (output) DOUBLE PRECISION array, dimension (N) X* The diagonal elements of the tridiagonal matrix T: X* D(i) = A(i,i). X* X* E (output) DOUBLE PRECISION array, dimension (N-1) X* The off-diagonal elements of the tridiagonal matrix T: X* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. X* X* TAU (output) DOUBLE PRECISION array, dimension (N-1) X* The scalar factors of the elementary reflectors (see Further X* Details). X* X* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) X* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. X* X* LWORK (input) INTEGER X* The dimension of the array WORK. LWORK >= 1. X* For optimum performance LWORK >= N*NB, where NB is the X* optimal blocksize. X* X* INFO (output) INTEGER X* = 0: successful exit X* < 0: if INFO = -i, the i-th argument had an illegal value X* X* Further Details X* =============== X* X* If UPLO = 'U', the matrix Q is represented as a product of elementary X* reflectors X* X* Q = H(n-1) . . . H(2) H(1). X* X* Each H(i) has the form X* X* H(i) = I - tau * v * v' X* X* where tau is a real scalar, and v is a real vector with X* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in X* A(1:i-1,i+1), and tau in TAU(i). X* X* If UPLO = 'L', the matrix Q is represented as a product of elementary X* reflectors X* X* Q = H(1) H(2) . . . H(n-1). X* X* Each H(i) has the form X* X* H(i) = I - tau * v * v' X* X* where tau is a real scalar, and v is a real vector with X* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), X* and tau in TAU(i). X* X* The contents of A on exit are illustrated by the following examples X* with n = 5: X* X* if UPLO = 'U': if UPLO = 'L': X* X* ( d e v2 v3 v4 ) ( d ) X* ( d e v3 v4 ) ( e d ) X* ( d e v4 ) ( v1 e d ) X* ( d e ) ( v1 v2 e d ) X* ( d ) ( v1 v2 v3 e d ) X* X* where d and e denote diagonal and off-diagonal elements of T, and vi X* denotes an element of the vector defining H(i). X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ONE X PARAMETER ( ONE = 1.0D0 ) X* .. X* .. Local Scalars .. X LOGICAL UPPER X INTEGER I, IINFO, IWS, J, KK, LDWORK, NB, NBMIN, NX X* .. X* .. External Subroutines .. X EXTERNAL DLATRD, DSYR2K, DSYTD2, XERBLA X* .. X* .. Intrinsic Functions .. X INTRINSIC MAX X* .. X* .. External Functions .. X LOGICAL LSAME X INTEGER ILAENV X EXTERNAL LSAME, ILAENV X* .. X* .. Executable Statements .. X* X* Test the input parameters X* X INFO = 0 X UPPER = LSAME( UPLO, 'U' ) X IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN X INFO = -1 X ELSE IF( N.LT.0 ) THEN X INFO = -2 X ELSE IF( LDA.LT.MAX( 1, N ) ) THEN X INFO = -4 X ELSE IF( LWORK.LT.1 ) THEN X INFO = -9 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DSYTRD', -INFO ) X RETURN X END IF X* X* Quick return if possible X* X IF( N.EQ.0 ) THEN X WORK( 1 ) = 1 X RETURN X END IF X* X* Determine the block size. X* X NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) X NX = N X IWS = 1 X IF( NB.GT.1 .AND. NB.LT.N ) THEN X* X* Determine when to cross over from blocked to unblocked code X* (last block is always handled by unblocked code). X* X NX = MAX( NB, ILAENV( 3, 'DSYTRD', UPLO, N, -1, -1, -1 ) ) X IF( NX.LT.N ) THEN X* X* Determine if workspace is large enough for blocked code. X* X LDWORK = N X IWS = LDWORK*NB X IF( LWORK.LT.IWS ) THEN X* X* Not enough workspace to use optimal NB: determine the X* minimum value of NB, and reduce NB or force use of X* unblocked code by setting NX = N. X* X NB = MAX( LWORK / LDWORK, 1 ) X NBMIN = ILAENV( 2, 'DSYTRD', UPLO, N, -1, -1, -1 ) X IF( NB.LT.NBMIN ) X $ NX = N X END IF X ELSE X NX = N X END IF X ELSE X NB = 1 X END IF X* X IF( UPPER ) THEN X* X* Reduce the upper triangle of A. X* Columns 1:kk are handled by the unblocked method. X* X KK = N - ( ( N-NX+NB-1 ) / NB )*NB X DO 20 I = N - NB + 1, KK + 1, -NB X* X* Reduce columns i:i+nb-1 to tridiagonal form and form the X* matrix W which is needed to update the unreduced part of X* the matrix X* X CALL DLATRD( UPLO, I+NB-1, NB, A, LDA, E, TAU, WORK, X $ LDWORK ) X* X* Update the unreduced submatrix A(1:i-1,1:i-1), using an X* update of the form: A := A - V*W' - W*V' X* X CALL DSYR2K( UPLO, 'No transpose', I-1, NB, -ONE, A( 1, I ), X $ LDA, WORK, LDWORK, ONE, A, LDA ) X* X* Copy superdiagonal elements back into A, and diagonal X* elements into D X* X DO 10 J = I, I + NB - 1 X A( J-1, J ) = E( J-1 ) X D( J ) = A( J, J ) X 10 CONTINUE X 20 CONTINUE X* X* Use unblocked code to reduce the last or only block X* X CALL DSYTD2( UPLO, KK, A, LDA, D, E, TAU, IINFO ) X ELSE X* X* Reduce the lower triangle of A X* X DO 40 I = 1, N - NX, NB X* X* Reduce columns i:i+nb-1 to tridiagonal form and form the X* matrix W which is needed to update the unreduced part of X* the matrix X* X CALL DLATRD( UPLO, N-I+1, NB, A( I, I ), LDA, E( I ), X $ TAU( I ), WORK, LDWORK ) X* X* Update the unreduced submatrix A(i+ib:n,i+ib:n), using X* an update of the form: A := A - V*W' - W*V' X* X CALL DSYR2K( UPLO, 'No transpose', N-I-NB+1, NB, -ONE, X $ A( I+NB, I ), LDA, WORK( NB+1 ), LDWORK, ONE, X $ A( I+NB, I+NB ), LDA ) X* X* Copy subdiagonal elements back into A, and diagonal X* elements into D X* X DO 30 J = I, I + NB - 1 X A( J+1, J ) = E( J ) X D( J ) = A( J, J ) X 30 CONTINUE X 40 CONTINUE X* X* Use unblocked code to reduce the last or only block X* X CALL DSYTD2( UPLO, N-I+1, A( I, I ), LDA, D( I ), E( I ), X $ TAU( I ), IINFO ) X END IF X* X WORK( 1 ) = IWS X RETURN X* X* End of DSYTRD X* X END X* X SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) X* X* -- LAPACK routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* September 30, 1994 X* X* .. Scalar Arguments .. X CHARACTER COMPZ X INTEGER INFO, LDZ, N X* .. X* .. Array Arguments .. X DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) X* .. X* X* Purpose X* ======= X* X* DSTEQR computes all eigenvalues and, optionally, eigenvectors of a X* symmetric tridiagonal matrix using the implicit QL or QR method. X* The eigenvectors of a full or band symmetric matrix can also be found X* if DSYTRD or DSPTRD or DSBTRD has been used to reduce this matrix to X* tridiagonal form. X* X* Arguments X* ========= X* X* COMPZ (input) CHARACTER*1 X* = 'N': Compute eigenvalues only. X* = 'V': Compute eigenvalues and eigenvectors of the original X* symmetric matrix. On entry, Z must contain the X* orthogonal matrix used to reduce the original matrix X* to tridiagonal form. X* = 'I': Compute eigenvalues and eigenvectors of the X* tridiagonal matrix. Z is initialized to the identity X* matrix. X* X* N (input) INTEGER X* The order of the matrix. N >= 0. X* X* D (input/output) DOUBLE PRECISION array, dimension (N) X* On entry, the diagonal elements of the tridiagonal matrix. X* On exit, if INFO = 0, the eigenvalues in ascending order. X* X* E (input/output) DOUBLE PRECISION array, dimension (N-1) X* On entry, the (n-1) subdiagonal elements of the tridiagonal X* matrix. X* On exit, E has been destroyed. X* X* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) X* On entry, if COMPZ = 'V', then Z contains the orthogonal X* matrix used in the reduction to tridiagonal form. X* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the X* orthonormal eigenvectors of the original symmetric matrix, X* and if COMPZ = 'I', Z contains the orthonormal eigenvectors X* of the symmetric tridiagonal matrix. X* If COMPZ = 'N', then Z is not referenced. X* X* LDZ (input) INTEGER X* The leading dimension of the array Z. LDZ >= 1, and if X* eigenvectors are desired, then LDZ >= max(1,N). X* X* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2)) X* If COMPZ = 'N', then WORK is not referenced. X* X* INFO (output) INTEGER X* = 0: successful exit X* < 0: if INFO = -i, the i-th argument had an illegal value X* > 0: the algorithm has failed to find all the eigenvalues in X* a total of 30*N iterations; if INFO = i, then i X* elements of E have not converged to zero; on exit, D X* and E contain the elements of a symmetric tridiagonal X* matrix which is orthogonally similar to the original X* matrix. X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ZERO, ONE, TWO, THREE X PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, X $ THREE = 3.0D0 ) X INTEGER MAXIT X PARAMETER ( MAXIT = 30 ) X* .. X* .. Local Scalars .. X INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND, X $ LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1, X $ NM1, NMAXIT X DOUBLE PRECISION ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2, X $ S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST X* .. X* .. External Functions .. X LOGICAL LSAME X DOUBLE PRECISION DLAMCH, DLANST, DLAPY2 X EXTERNAL LSAME, DLAMCH, DLANST, DLAPY2 X* .. X* .. External Subroutines .. X EXTERNAL DLAE2, DLAEV2, DLARTG, DLASCL, DLASET, DLASR, X $ DLASRT, DSWAP, XERBLA X* .. X* .. Intrinsic Functions .. X INTRINSIC ABS, MAX, SIGN, SQRT X* .. X* .. Executable Statements .. X* X* Test the input parameters. X* X INFO = 0 X* X IF( LSAME( COMPZ, 'N' ) ) THEN X ICOMPZ = 0 X ELSE IF( LSAME( COMPZ, 'V' ) ) THEN X ICOMPZ = 1 X ELSE IF( LSAME( COMPZ, 'I' ) ) THEN X ICOMPZ = 2 X ELSE X ICOMPZ = -1 X END IF X IF( ICOMPZ.LT.0 ) THEN X INFO = -1 X ELSE IF( N.LT.0 ) THEN X INFO = -2 X ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, X $ N ) ) ) THEN X INFO = -6 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DSTEQR', -INFO ) X RETURN X END IF X* X* Quick return if possible X* X IF( N.EQ.0 ) X $ RETURN X* X IF( N.EQ.1 ) THEN X IF( ICOMPZ.EQ.2 ) X $ Z( 1, 1 ) = ONE X RETURN X END IF X* X* Determine the unit roundoff and over/underflow thresholds. X* X EPS = DLAMCH( 'E' ) X EPS2 = EPS**2 X SAFMIN = DLAMCH( 'S' ) X SAFMAX = ONE / SAFMIN X SSFMAX = SQRT( SAFMAX ) / THREE X SSFMIN = SQRT( SAFMIN ) / EPS2 X* X* Compute the eigenvalues and eigenvectors of the tridiagonal X* matrix. X* X IF( ICOMPZ.EQ.2 ) X $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) X* X NMAXIT = N*MAXIT X JTOT = 0 X* X* Determine where the matrix splits and choose QL or QR iteration X* for each block, according to whether top or bottom diagonal X* element is smaller. X* X L1 = 1 X NM1 = N - 1 X* X 10 CONTINUE X IF( L1.GT.N ) X $ GO TO 160 X IF( L1.GT.1 ) X $ E( L1-1 ) = ZERO X IF( L1.LE.NM1 ) THEN X DO 20 M = L1, NM1 X TST = ABS( E( M ) ) X IF( TST.EQ.ZERO ) X $ GO TO 30 X IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+ X $ 1 ) ) ) )*EPS ) THEN X E( M ) = ZERO X GO TO 30 X END IF X 20 CONTINUE X END IF X M = N X* X 30 CONTINUE X L = L1 X LSV = L X LEND = M X LENDSV = LEND X L1 = M + 1 X IF( LEND.EQ.L ) X $ GO TO 10 X* X* Scale submatrix in rows and columns L to LEND X* X ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) ) X ISCALE = 0 X IF( ANORM.EQ.ZERO ) X $ GO TO 10 X IF( ANORM.GT.SSFMAX ) THEN X ISCALE = 1 X CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, X $ INFO ) X CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, X $ INFO ) X ELSE IF( ANORM.LT.SSFMIN ) THEN X ISCALE = 2 X CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N, X $ INFO ) X CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, X $ INFO ) X END IF X* X* Choose between QL and QR iteration X* X IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN X LEND = LSV X L = LENDSV X END IF X* X IF( LEND.GT.L ) THEN X* X* QL Iteration X* X* Look for small subdiagonal element. X* X 40 CONTINUE X IF( L.NE.LEND ) THEN X LENDM1 = LEND - 1 X DO 50 M = L, LENDM1 X TST = ABS( E( M ) )**2 X IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+ X $ SAFMIN )GO TO 60 X 50 CONTINUE X END IF X* X M = LEND X* X 60 CONTINUE X IF( M.LT.LEND ) X $ E( M ) = ZERO X P = D( L ) X IF( M.EQ.L ) X $ GO TO 80 X* X* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 X* to compute its eigensystem. X* X IF( M.EQ.L+1 ) THEN X IF( ICOMPZ.GT.0 ) THEN X CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S ) X WORK( L ) = C X WORK( N-1+L ) = S X CALL DLASR( 'R', 'V', 'B', N, 2, WORK( L ), X $ WORK( N-1+L ), Z( 1, L ), LDZ ) X ELSE X CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 ) X END IF X D( L ) = RT1 X D( L+1 ) = RT2 X E( L ) = ZERO X L = L + 2 X IF( L.LE.LEND ) X $ GO TO 40 X GO TO 140 X END IF X* X IF( JTOT.EQ.NMAXIT ) X $ GO TO 140 X JTOT = JTOT + 1 X* X* Form shift. X* X G = ( D( L+1 )-P ) / ( TWO*E( L ) ) X R = DLAPY2( G, ONE ) X G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) ) X* X S = ONE X C = ONE X P = ZERO X* X* Inner loop X* X MM1 = M - 1 X DO 70 I = MM1, L, -1 X F = S*E( I ) X B = C*E( I ) X CALL DLARTG( G, F, C, S, R ) X IF( I.NE.M-1 ) X $ E( I+1 ) = R X G = D( I+1 ) - P X R = ( D( I )-G )*S + TWO*C*B X P = S*R X D( I+1 ) = G + P X G = C*R - B X* X* If eigenvectors are desired, then save rotations. X* X IF( ICOMPZ.GT.0 ) THEN X WORK( I ) = C X WORK( N-1+I ) = -S X END IF X* X 70 CONTINUE X* X* If eigenvectors are desired, then apply saved rotations. X* X IF( ICOMPZ.GT.0 ) THEN X MM = M - L + 1 X CALL DLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ), X $ Z( 1, L ), LDZ ) X END IF X* X D( L ) = D( L ) - P X E( L ) = G X GO TO 40 X* X* Eigenvalue found. X* X 80 CONTINUE X D( L ) = P X* X L = L + 1 X IF( L.LE.LEND ) X $ GO TO 40 X GO TO 140 X* X ELSE X* X* QR Iteration X* X* Look for small superdiagonal element. X* X 90 CONTINUE X IF( L.NE.LEND ) THEN X LENDP1 = LEND + 1 X DO 100 M = L, LENDP1, -1 X TST = ABS( E( M-1 ) )**2 X IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+ X $ SAFMIN )GO TO 110 X 100 CONTINUE X END IF X* X M = LEND X* X 110 CONTINUE X IF( M.GT.LEND ) X $ E( M-1 ) = ZERO X P = D( L ) X IF( M.EQ.L ) X $ GO TO 130 X* X* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 X* to compute its eigensystem. X* X IF( M.EQ.L-1 ) THEN X IF( ICOMPZ.GT.0 ) THEN X CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S ) X WORK( M ) = C X WORK( N-1+M ) = S X CALL DLASR( 'R', 'V', 'F', N, 2, WORK( M ), X $ WORK( N-1+M ), Z( 1, L-1 ), LDZ ) X ELSE X CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 ) X END IF X D( L-1 ) = RT1 X D( L ) = RT2 X E( L-1 ) = ZERO X L = L - 2 X IF( L.GE.LEND ) X $ GO TO 90 X GO TO 140 X END IF X* X IF( JTOT.EQ.NMAXIT ) X $ GO TO 140 X JTOT = JTOT + 1 X* X* Form shift. X* X G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) ) X R = DLAPY2( G, ONE ) X G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) ) X* X S = ONE X C = ONE X P = ZERO X* X* Inner loop X* X LM1 = L - 1 X DO 120 I = M, LM1 X F = S*E( I ) X B = C*E( I ) X CALL DLARTG( G, F, C, S, R ) X IF( I.NE.M ) X $ E( I-1 ) = R X G = D( I ) - P X R = ( D( I+1 )-G )*S + TWO*C*B X P = S*R X D( I ) = G + P X G = C*R - B X* X* If eigenvectors are desired, then save rotations. X* X IF( ICOMPZ.GT.0 ) THEN X WORK( I ) = C X WORK( N-1+I ) = S X END IF X* X 120 CONTINUE X* X* If eigenvectors are desired, then apply saved rotations. X* X IF( ICOMPZ.GT.0 ) THEN X MM = L - M + 1 X CALL DLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ), X $ Z( 1, M ), LDZ ) X END IF X* X D( L ) = D( L ) - P X E( LM1 ) = G X GO TO 90 X* X* Eigenvalue found. X* X 130 CONTINUE X D( L ) = P X* X L = L - 1 X IF( L.GE.LEND ) X $ GO TO 90 X GO TO 140 X* X END IF X* X* Undo scaling if necessary X* X 140 CONTINUE X IF( ISCALE.EQ.1 ) THEN X CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1, X $ D( LSV ), N, INFO ) X CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ), X $ N, INFO ) X ELSE IF( ISCALE.EQ.2 ) THEN X CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1, X $ D( LSV ), N, INFO ) X CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ), X $ N, INFO ) X END IF X* X* Check for no convergence to an eigenvalue after a total X* of N*MAXIT iterations. X* X IF( JTOT.LT.NMAXIT ) X $ GO TO 10 X DO 150 I = 1, N - 1 X IF( E( I ).NE.ZERO ) X $ INFO = INFO + 1 X 150 CONTINUE X GO TO 190 X* X* Order eigenvalues and eigenvectors. X* X 160 CONTINUE X IF( ICOMPZ.EQ.0 ) THEN X* X* Use Quick Sort X* X CALL DLASRT( 'I', N, D, INFO ) X* X ELSE X* X* Use Selection Sort to minimize swaps of eigenvectors X* X DO 180 II = 2, N X I = II - 1 X K = I X P = D( I ) X DO 170 J = II, N X IF( D( J ).LT.P ) THEN X K = J X P = D( J ) X END IF X 170 CONTINUE X IF( K.NE.I ) THEN X D( K ) = D( I ) X D( I ) = P X CALL DSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 ) X END IF X 180 CONTINUE X END IF X* X 190 CONTINUE X RETURN X* X* End of DSTEQR X* X END X SUBROUTINE DSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, X $ IWORK, IFAIL, INFO ) X* X* -- LAPACK routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* September 30, 1994 X* X* .. Scalar Arguments .. X INTEGER INFO, LDZ, M, N X* .. X* .. Array Arguments .. X INTEGER IBLOCK( * ), IFAIL( * ), ISPLIT( * ), X $ IWORK( * ) X DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * ) X* .. X* X* Purpose X* ======= X* X* DSTEIN computes the eigenvectors of a real symmetric tridiagonal X* matrix T corresponding to specified eigenvalues, using inverse X* iteration. X* X* The maximum number of iterations allowed for each eigenvector is X* specified by an internal parameter MAXITS (currently set to 5). X* X* Arguments X* ========= X* X* N (input) INTEGER X* The order of the matrix. N >= 0. X* X* D (input) DOUBLE PRECISION array, dimension (N) X* The n diagonal elements of the tridiagonal matrix T. X* X* E (input) DOUBLE PRECISION array, dimension (N) X* The (n-1) subdiagonal elements of the tridiagonal matrix X* T, in elements 1 to N-1. E(N) need not be set. X* X* M (input) INTEGER X* The number of eigenvectors to be found. 0 <= M <= N. X* X* W (input) DOUBLE PRECISION array, dimension (N) X* The first M elements of W contain the eigenvalues for X* which eigenvectors are to be computed. The eigenvalues X* should be grouped by split-off block and ordered from X* smallest to largest within the block. ( The output array X* W from DSTEBZ with ORDER = 'B' is expected here. ) X* X* IBLOCK (input) INTEGER array, dimension (N) X* The submatrix indices associated with the corresponding X* eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to X* the first submatrix from the top, =2 if W(i) belongs to X* the second submatrix, etc. ( The output array IBLOCK X* from DSTEBZ is expected here. ) X* X* ISPLIT (input) INTEGER array, dimension (N) X* The splitting points, at which T breaks up into submatrices. X* The first submatrix consists of rows/columns 1 to X* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1 X* through ISPLIT( 2 ), etc. X* ( The output array ISPLIT from DSTEBZ is expected here. ) X* X* Z (output) DOUBLE PRECISION array, dimension (LDZ, M) X* The computed eigenvectors. The eigenvector associated X* with the eigenvalue W(i) is stored in the i-th column of X* Z. Any vector which fails to converge is set to its current X* iterate after MAXITS iterations. X* X* LDZ (input) INTEGER X* The leading dimension of the array Z. LDZ >= max(1,N). X* X* WORK (workspace) DOUBLE PRECISION array, dimension (5*N) X* X* IWORK (workspace) INTEGER array, dimension (N) X* X* IFAIL (output) INTEGER array, dimension (M) X* On normal exit, all elements of IFAIL are zero. X* If one or more eigenvectors fail to converge after X* MAXITS iterations, then their indices are stored in X* array IFAIL. X* X* INFO (output) INTEGER X* = 0: successful exit. X* < 0: if INFO = -i, the i-th argument had an illegal value X* > 0: if INFO = i, then i eigenvectors failed to converge X* in MAXITS iterations. Their indices are stored in X* array IFAIL. X* X* Internal Parameters X* =================== X* X* MAXITS INTEGER, default = 5 X* The maximum number of iterations performed. X* X* EXTRA INTEGER, default = 2 X* The number of iterations performed after norm growth X* criterion is satisfied, should be at least 1. X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ZERO, ONE, TEN, ODM3, ODM1 X PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TEN = 1.0D+1, X $ ODM3 = 1.0D-3, ODM1 = 1.0D-1 ) X INTEGER MAXITS, EXTRA X PARAMETER ( MAXITS = 5, EXTRA = 2 ) X* .. X* .. Local Scalars .. X INTEGER B1, BLKSIZ, BN, GPIND, I, IINFO, INDRV1, X $ INDRV2, INDRV3, INDRV4, INDRV5, ITS, J, J1, X $ JBLK, JMAX, NBLK, NRMCHK X DOUBLE PRECISION DTPCRT, EPS, EPS1, NRM, ONENRM, ORTOL, PERTOL, X $ SCL, SEP, TOL, XJ, XJM, ZTR X* .. X* .. Local Arrays .. X INTEGER ISEED( 4 ) X* .. X* .. External Functions .. X INTEGER IDAMAX X DOUBLE PRECISION DASUM, DDOT, DLAMCH, DNRM2 X EXTERNAL IDAMAX, DASUM, DDOT, DLAMCH, DNRM2 X* .. X* .. External Subroutines .. X EXTERNAL DAXPY, DCOPY, DLAGTF, DLAGTS, DLARNV, DSCAL, X $ XERBLA X* .. X* .. Intrinsic Functions .. X INTRINSIC ABS, MAX, SQRT X* .. X* .. Executable Statements .. X* X* Test the input parameters. X* X INFO = 0 X DO 10 I = 1, M X IFAIL( I ) = 0 X 10 CONTINUE X* X IF( N.LT.0 ) THEN X INFO = -1 X ELSE IF( M.LT.0 .OR. M.GT.N ) THEN X INFO = -4 X ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN X INFO = -9 X ELSE X DO 20 J = 2, M X IF( IBLOCK( J ).LT.IBLOCK( J-1 ) ) THEN X INFO = -6 X GO TO 30 X END IF X IF( IBLOCK( J ).EQ.IBLOCK( J-1 ) .AND. W( J ).LT.W( J-1 ) ) X $ THEN X INFO = -5 X GO TO 30 X END IF X 20 CONTINUE X 30 CONTINUE X END IF X* X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DSTEIN', -INFO ) X RETURN X END IF X* X* Quick return if possible X* X IF( N.EQ.0 .OR. M.EQ.0 ) THEN X RETURN X ELSE IF( N.EQ.1 ) THEN X Z( 1, 1 ) = ONE X RETURN X END IF X* X* Get machine constants. X* X EPS = DLAMCH( 'Precision' ) X* X* Initialize seed for random number generator DLARNV. X* X DO 40 I = 1, 4 X ISEED( I ) = 1 X 40 CONTINUE X* X* Initialize pointers. X* X INDRV1 = 0 X INDRV2 = INDRV1 + N X INDRV3 = INDRV2 + N X INDRV4 = INDRV3 + N X INDRV5 = INDRV4 + N X* X* Compute eigenvectors of matrix blocks. X* X J1 = 1 X DO 160 NBLK = 1, IBLOCK( M ) X* X* Find starting and ending indices of block nblk. X* X IF( NBLK.EQ.1 ) THEN X B1 = 1 X ELSE X B1 = ISPLIT( NBLK-1 ) + 1 X END IF X BN = ISPLIT( NBLK ) X BLKSIZ = BN - B1 + 1 X IF( BLKSIZ.EQ.1 ) X $ GO TO 60 X GPIND = B1 X* X* Compute reorthogonalization criterion and stopping criterion. X* X ONENRM = ABS( D( B1 ) ) + ABS( E( B1 ) ) X ONENRM = MAX( ONENRM, ABS( D( BN ) )+ABS( E( BN-1 ) ) ) X DO 50 I = B1 + 1, BN - 1 X ONENRM = MAX( ONENRM, ABS( D( I ) )+ABS( E( I-1 ) )+ X $ ABS( E( I ) ) ) X 50 CONTINUE X ORTOL = ODM3*ONENRM X* X DTPCRT = SQRT( ODM1 / BLKSIZ ) X* X* Loop through eigenvalues of block nblk. X* X 60 CONTINUE X JBLK = 0 X DO 150 J = J1, M X IF( IBLOCK( J ).NE.NBLK ) THEN X J1 = J X GO TO 160 X END IF X JBLK = JBLK + 1 X XJ = W( J ) X* X* Skip all the work if the block size is one. X* X IF( BLKSIZ.EQ.1 ) THEN X WORK( INDRV1+1 ) = ONE X GO TO 120 X END IF X* X* If eigenvalues j and j-1 are too close, add a relatively X* small perturbation. X* X IF( JBLK.GT.1 ) THEN X EPS1 = ABS( EPS*XJ ) X PERTOL = TEN*EPS1 X SEP = XJ - XJM X IF( SEP.LT.PERTOL ) X $ XJ = XJM + PERTOL X END IF X* X ITS = 0 X NRMCHK = 0 X* X* Get random starting vector. X* X CALL DLARNV( 2, ISEED, BLKSIZ, WORK( INDRV1+1 ) ) X* X* Copy the matrix T so it won't be destroyed in factorization. X* X CALL DCOPY( BLKSIZ, D( B1 ), 1, WORK( INDRV4+1 ), 1 ) X CALL DCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV2+2 ), 1 ) X CALL DCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV3+1 ), 1 ) X* X* Compute LU factors with partial pivoting ( PT = LU ) X* X TOL = ZERO X CALL DLAGTF( BLKSIZ, WORK( INDRV4+1 ), XJ, WORK( INDRV2+2 ), X $ WORK( INDRV3+1 ), TOL, WORK( INDRV5+1 ), IWORK, X $ IINFO ) X* X* Update iteration count. X* X 70 CONTINUE X ITS = ITS + 1 X IF( ITS.GT.MAXITS ) X $ GO TO 100 X* X* Normalize and scale the righthand side vector Pb. X* X SCL = BLKSIZ*ONENRM*MAX( EPS, X $ ABS( WORK( INDRV4+BLKSIZ ) ) ) / X $ DASUM( BLKSIZ, WORK( INDRV1+1 ), 1 ) X CALL DSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 ) X* X* Solve the system LU = Pb. X* X CALL DLAGTS( -1, BLKSIZ, WORK( INDRV4+1 ), WORK( INDRV2+2 ), X $ WORK( INDRV3+1 ), WORK( INDRV5+1 ), IWORK, X $ WORK( INDRV1+1 ), TOL, IINFO ) X* X* Reorthogonalize by modified Gram-Schmidt if eigenvalues are X* close enough. X* X IF( JBLK.EQ.1 ) X $ GO TO 90 X IF( ABS( XJ-XJM ).GT.ORTOL ) X $ GPIND = J X IF( GPIND.NE.J ) THEN X DO 80 I = GPIND, J - 1 X ZTR = -DDOT( BLKSIZ, WORK( INDRV1+1 ), 1, Z( B1, I ), X $ 1 ) X CALL DAXPY( BLKSIZ, ZTR, Z( B1, I ), 1, X $ WORK( INDRV1+1 ), 1 ) X 80 CONTINUE X END IF X* X* Check the infinity norm of the iterate. X* X 90 CONTINUE X JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 ) X NRM = ABS( WORK( INDRV1+JMAX ) ) X* X* Continue for additional iterations after norm reaches X* stopping criterion. X* X IF( NRM.LT.DTPCRT ) X $ GO TO 70 X NRMCHK = NRMCHK + 1 X IF( NRMCHK.LT.EXTRA+1 ) X $ GO TO 70 X* X GO TO 110 X* X* If stopping criterion was not satisfied, update info and X* store eigenvector number in array ifail. X* X 100 CONTINUE X INFO = INFO + 1 X IFAIL( INFO ) = J X* X* Accept iterate as jth eigenvector. X* X 110 CONTINUE X SCL = ONE / DNRM2( BLKSIZ, WORK( INDRV1+1 ), 1 ) X JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 ) X IF( WORK( INDRV1+JMAX ).LT.ZERO ) X $ SCL = -SCL X CALL DSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 ) X 120 CONTINUE X DO 130 I = 1, N X Z( I, J ) = ZERO X 130 CONTINUE X DO 140 I = 1, BLKSIZ X Z( B1+I-1, J ) = WORK( INDRV1+I ) X 140 CONTINUE X* X* Save the shift to check eigenvalue spacing at next X* iteration. X* X XJM = XJ X* X 150 CONTINUE X 160 CONTINUE X* X RETURN X* X* End of DSTEIN X* X END X SUBROUTINE DORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) X* X* -- LAPACK routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* September 30, 1994 X* X* .. Scalar Arguments .. X CHARACTER UPLO X INTEGER INFO, LDA, LWORK, N X* .. X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( LWORK ) X* .. X* X* Purpose X* ======= X* X* DORGTR generates a real orthogonal matrix Q which is defined as the X* product of n-1 elementary reflectors of order N, as returned by X* DSYTRD: X* X* if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), X* X* if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). X* X* Arguments X* ========= X* X* UPLO (input) CHARACTER*1 X* = 'U': Upper triangle of A contains elementary reflectors X* from DSYTRD; X* = 'L': Lower triangle of A contains elementary reflectors X* from DSYTRD. X* X* N (input) INTEGER X* The order of the matrix Q. N >= 0. X* X* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) X* On entry, the vectors which define the elementary reflectors, X* as returned by DSYTRD. X* On exit, the N-by-N orthogonal matrix Q. X* X* LDA (input) INTEGER X* The leading dimension of the array A. LDA >= max(1,N). X* X* TAU (input) DOUBLE PRECISION array, dimension (N-1) X* TAU(i) must contain the scalar factor of the elementary X* reflector H(i), as returned by DSYTRD. X* X* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) X* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. X* X* LWORK (input) INTEGER X* The dimension of the array WORK. LWORK >= max(1,N-1). X* For optimum performance LWORK >= (N-1)*NB, where NB is X* the optimal blocksize. X* X* INFO (output) INTEGER X* = 0: successful exit X* < 0: if INFO = -i, the i-th argument had an illegal value X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ZERO, ONE X PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) X* .. X* .. Local Scalars .. X LOGICAL UPPER X INTEGER I, IINFO, J X* .. X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. X* .. External Subroutines .. X EXTERNAL DORGQL, DORGQR, XERBLA X* .. X* .. Intrinsic Functions .. X INTRINSIC MAX X* .. X* .. Executable Statements .. X* X* Test the input arguments X* X INFO = 0 X UPPER = LSAME( UPLO, 'U' ) X IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN X INFO = -1 X ELSE IF( N.LT.0 ) THEN X INFO = -2 X ELSE IF( LDA.LT.MAX( 1, N ) ) THEN X INFO = -4 X ELSE IF( LWORK.LT.MAX( 1, N-1 ) ) THEN X INFO = -7 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DORGTR', -INFO ) X RETURN X END IF X* X* Quick return if possible X* X IF( N.EQ.0 ) THEN X WORK( 1 ) = 1 X RETURN X END IF X* X IF( UPPER ) THEN X* X* Q was determined by a call to DSYTRD with UPLO = 'U' X* X* Shift the vectors which define the elementary reflectors one X* column to the left, and set the last row and column of Q to X* those of the unit matrix X* X DO 20 J = 1, N - 1 X DO 10 I = 1, J - 1 X A( I, J ) = A( I, J+1 ) X 10 CONTINUE X A( N, J ) = ZERO X 20 CONTINUE X DO 30 I = 1, N - 1 X A( I, N ) = ZERO X 30 CONTINUE X A( N, N ) = ONE X* X* Generate Q(1:n-1,1:n-1) X* X CALL DORGQL( N-1, N-1, N-1, A, LDA, TAU, WORK, LWORK, IINFO ) X* X ELSE X* X* Q was determined by a call to DSYTRD with UPLO = 'L'. X* X* Shift the vectors which define the elementary reflectors one X* column to the right, and set the first row and column of Q to X* those of the unit matrix X* X DO 50 J = N, 2, -1 X A( 1, J ) = ZERO X DO 40 I = J + 1, N X A( I, J ) = A( I, J-1 ) X 40 CONTINUE X 50 CONTINUE X A( 1, 1 ) = ONE X DO 60 I = 2, N X A( I, 1 ) = ZERO X 60 CONTINUE X IF( N.GT.1 ) THEN X* X* Generate Q(2:n,2:n) X* X CALL DORGQR( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK, X $ LWORK, IINFO ) X END IF X END IF X RETURN X* X* End of DORGTR X* X END X SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB ) X* X* -- LAPACK auxiliary routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* February 29, 1992 X* X* .. Scalar Arguments .. X CHARACTER UPLO X INTEGER LDA, LDB, M, N X* .. X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), B( LDB, * ) X* .. X* X* Purpose X* ======= X* X* DLACPY copies all or part of a two-dimensional matrix A to another X* matrix B. X* X* Arguments X* ========= X* X* UPLO (input) CHARACTER*1 X* Specifies the part of the matrix A to be copied to B. X* = 'U': Upper triangular part X* = 'L': Lower triangular part X* Otherwise: All of the matrix A X* X* M (input) INTEGER X* The number of rows of the matrix A. M >= 0. X* X* N (input) INTEGER X* The number of columns of the matrix A. N >= 0. X* X* A (input) DOUBLE PRECISION array, dimension (LDA,N) X* The m by n matrix A. If UPLO = 'U', only the upper triangle X* or trapezoid is accessed; if UPLO = 'L', only the lower X* triangle or trapezoid is accessed. X* X* LDA (input) INTEGER X* The leading dimension of the array A. LDA >= max(1,M). X* X* B (output) DOUBLE PRECISION array, dimension (LDB,N) X* On exit, B = A in the locations specified by UPLO. X* X* LDB (input) INTEGER X* The leading dimension of the array B. LDB >= max(1,M). X* X* ===================================================================== X* X* .. Local Scalars .. X INTEGER I, J X* .. X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. X* .. Intrinsic Functions .. X INTRINSIC MIN X* .. X* .. Executable Statements .. X* X IF( LSAME( UPLO, 'U' ) ) THEN X DO 20 J = 1, N X DO 10 I = 1, MIN( J, M ) X B( I, J ) = A( I, J ) X 10 CONTINUE X 20 CONTINUE X ELSE IF( LSAME( UPLO, 'L' ) ) THEN X DO 40 J = 1, N X DO 30 I = J, M X B( I, J ) = A( I, J ) X 30 CONTINUE X 40 CONTINUE X ELSE X DO 60 J = 1, N X DO 50 I = 1, M X B( I, J ) = A( I, J ) X 50 CONTINUE X 60 CONTINUE X END IF X RETURN X* X* End of DLACPY X* X END X SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) X* X* -- LAPACK routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* March 31, 1993 X* X* .. Scalar Arguments .. X INTEGER INFO, LDA, M, N X* .. X* .. Array Arguments .. X INTEGER IPIV( * ) X DOUBLE PRECISION A( LDA, * ) X* .. X* X* Purpose X* ======= X* X* DGETRF computes an LU factorization of a general M-by-N matrix A X* using partial pivoting with row interchanges. X* X* The factorization has the form X* A = P * L * U X* where P is a permutation matrix, L is lower triangular with unit X* diagonal elements (lower trapezoidal if m > n), and U is upper X* triangular (upper trapezoidal if m < n). X* X* This is the right-looking Level 3 BLAS version of the algorithm. X* X* Arguments X* ========= X* X* M (input) INTEGER X* The number of rows of the matrix A. M >= 0. X* X* N (input) INTEGER X* The number of columns of the matrix A. N >= 0. X* X* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) X* On entry, the M-by-N matrix to be factored. X* On exit, the factors L and U from the factorization X* A = P*L*U; the unit diagonal elements of L are not stored. X* X* LDA (input) INTEGER X* The leading dimension of the array A. LDA >= max(1,M). X* X* IPIV (output) INTEGER array, dimension (min(M,N)) X* The pivot indices; for 1 <= i <= min(M,N), row i of the X* matrix was interchanged with row IPIV(i). X* X* INFO (output) INTEGER X* = 0: successful exit X* < 0: if INFO = -i, the i-th argument had an illegal value X* > 0: if INFO = i, U(i,i) is exactly zero. The factorization X* has been completed, but the factor U is exactly X* singular, and division by zero will occur if it is used X* to solve a system of equations. X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ONE X PARAMETER ( ONE = 1.0D+0 ) X* .. X* .. Local Scalars .. X INTEGER I, IINFO, J, JB, NB X* .. X* .. External Subroutines .. X EXTERNAL DGEMM, DGETF2, DLASWP, DTRSM, XERBLA X* .. X* .. External Functions .. X INTEGER ILAENV X EXTERNAL ILAENV X* .. X* .. Intrinsic Functions .. X INTRINSIC MAX, MIN X* .. X* .. Executable Statements .. X* X* Test the input parameters. X* X INFO = 0 X IF( M.LT.0 ) THEN X INFO = -1 X ELSE IF( N.LT.0 ) THEN X INFO = -2 X ELSE IF( LDA.LT.MAX( 1, M ) ) THEN X INFO = -4 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DGETRF', -INFO ) X RETURN X END IF X* X* Quick return if possible X* X IF( M.EQ.0 .OR. N.EQ.0 ) X $ RETURN X* X* Determine the block size for this environment. X* X NB = ILAENV( 1, 'DGETRF', ' ', M, N, -1, -1 ) X IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN X* X* Use unblocked code. X* X CALL DGETF2( M, N, A, LDA, IPIV, INFO ) X ELSE X* X* Use blocked code. X* X DO 20 J = 1, MIN( M, N ), NB X JB = MIN( MIN( M, N )-J+1, NB ) X* X* Factor diagonal and subdiagonal blocks and test for exact X* singularity. X* X CALL DGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO ) X* X* Adjust INFO and the pivot indices. X* X IF( INFO.EQ.0 .AND. IINFO.GT.0 ) X $ INFO = IINFO + J - 1 X DO 10 I = J, MIN( M, J+JB-1 ) X IPIV( I ) = J - 1 + IPIV( I ) X 10 CONTINUE X* X* Apply interchanges to columns 1:J-1. X* X CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) X* X IF( J+JB.LE.N ) THEN X* X* Apply interchanges to columns J+JB:N. X* X CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, X $ IPIV, 1 ) X* X* Compute block row of U. X* X CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, X $ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), X $ LDA ) X IF( J+JB.LE.M ) THEN X* X* Update trailing submatrix. X* X CALL DGEMM( 'No transpose', 'No transpose', M-J-JB+1, X $ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA, X $ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ), X $ LDA ) X END IF X END IF X 20 CONTINUE X END IF X RETURN X* X* End of DGETRF X* X END X DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) X* X* -- LAPACK auxiliary routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* October 31, 1992 X* X* .. Scalar Arguments .. X CHARACTER CMACH X* .. X* X* Purpose X* ======= X* X* DLAMCH determines double precision machine parameters. X* X* Arguments X* ========= X* X* CMACH (input) CHARACTER*1 X* Specifies the value to be returned by DLAMCH: X* = 'E' or 'e', DLAMCH := eps X* = 'S' or 's , DLAMCH := sfmin X* = 'B' or 'b', DLAMCH := base X* = 'P' or 'p', DLAMCH := eps*base X* = 'N' or 'n', DLAMCH := t X* = 'R' or 'r', DLAMCH := rnd X* = 'M' or 'm', DLAMCH := emin X* = 'U' or 'u', DLAMCH := rmin X* = 'L' or 'l', DLAMCH := emax X* = 'O' or 'o', DLAMCH := rmax X* X* where X* X* eps = relative machine precision X* sfmin = safe minimum, such that 1/sfmin does not overflow X* base = base of the machine X* prec = eps*base X* t = number of (base) digits in the mantissa X* rnd = 1.0 when rounding occurs in addition, 0.0 otherwise X* emin = minimum exponent before (gradual) underflow X* rmin = underflow threshold - base**(emin-1) X* emax = largest exponent before overflow X* rmax = overflow threshold - (base**emax)*(1-eps) X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ONE, ZERO X PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) X* .. X* .. Local Scalars .. X LOGICAL FIRST, LRND X INTEGER BETA, IMAX, IMIN, IT X DOUBLE PRECISION BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN, X $ RND, SFMIN, SMALL, T X* .. X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. X* .. External Subroutines .. X EXTERNAL DLAMC2 X* .. X* .. Save statement .. X SAVE FIRST, EPS, SFMIN, BASE, T, RND, EMIN, RMIN, X $ EMAX, RMAX, PREC X* .. X* .. Data statements .. X DATA FIRST / .TRUE. / X* .. X* .. Executable Statements .. X* X IF( FIRST ) THEN X FIRST = .FALSE. X CALL DLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX ) X BASE = BETA X T = IT X IF( LRND ) THEN X RND = ONE X EPS = ( BASE**( 1-IT ) ) / 2 X ELSE X RND = ZERO X EPS = BASE**( 1-IT ) X END IF X PREC = EPS*BASE X EMIN = IMIN X EMAX = IMAX X SFMIN = RMIN X SMALL = ONE / RMAX X IF( SMALL.GE.SFMIN ) THEN X* X* Use SMALL plus a bit, to avoid the possibility of rounding X* causing overflow when computing 1/sfmin. X* X SFMIN = SMALL*( ONE+EPS ) X END IF X END IF X* X IF( LSAME( CMACH, 'E' ) ) THEN X RMACH = EPS X ELSE IF( LSAME( CMACH, 'S' ) ) THEN X RMACH = SFMIN X ELSE IF( LSAME( CMACH, 'B' ) ) THEN X RMACH = BASE X ELSE IF( LSAME( CMACH, 'P' ) ) THEN X RMACH = PREC X ELSE IF( LSAME( CMACH, 'N' ) ) THEN X RMACH = T X ELSE IF( LSAME( CMACH, 'R' ) ) THEN X RMACH = RND X ELSE IF( LSAME( CMACH, 'M' ) ) THEN X RMACH = EMIN X ELSE IF( LSAME( CMACH, 'U' ) ) THEN X RMACH = RMIN X ELSE IF( LSAME( CMACH, 'L' ) ) THEN X RMACH = EMAX X ELSE IF( LSAME( CMACH, 'O' ) ) THEN X RMACH = RMAX X END IF X* X DLAMCH = RMACH X RETURN X* X* End of DLAMCH X* X END X* X************************************************************************ X* X SUBROUTINE DLAMC1( BETA, T, RND, IEEE1 ) X* X* -- LAPACK auxiliary routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* October 31, 1992 X* X* .. Scalar Arguments .. X LOGICAL IEEE1, RND X INTEGER BETA, T X* .. X* X* Purpose X* ======= X* X* DLAMC1 determines the machine parameters given by BETA, T, RND, and X* IEEE1. X* X* Arguments X* ========= X* X* BETA (output) INTEGER X* The base of the machine. X* X* T (output) INTEGER X* The number of ( BETA ) digits in the mantissa. X* X* RND (output) LOGICAL X* Specifies whether proper rounding ( RND = .TRUE. ) or X* chopping ( RND = .FALSE. ) occurs in addition. This may not X* be a reliable guide to the way in which the machine performs X* its arithmetic. X* X* IEEE1 (output) LOGICAL X* Specifies whether rounding appears to be done in the IEEE X* 'round to nearest' style. X* X* Further Details X* =============== X* X* The routine is based on the routine ENVRON by Malcolm and X* incorporates suggestions by Gentleman and Marovich. See X* X* Malcolm M. A. (1972) Algorithms to reveal properties of X* floating-point arithmetic. Comms. of the ACM, 15, 949-951. X* X* Gentleman W. M. and Marovich S. B. (1974) More on algorithms X* that reveal properties of floating point arithmetic units. X* Comms. of the ACM, 17, 276-277. X* X* ===================================================================== X* X* .. Local Scalars .. X LOGICAL FIRST, LIEEE1, LRND X INTEGER LBETA, LT X DOUBLE PRECISION A, B, C, F, ONE, QTR, SAVEC, T1, T2 X* .. X* .. External Functions .. X DOUBLE PRECISION DLAMC3 X EXTERNAL DLAMC3 X* .. X* .. Save statement .. X SAVE FIRST, LIEEE1, LBETA, LRND, LT X* .. X* .. Data statements .. X DATA FIRST / .TRUE. / X* .. X* .. Executable Statements .. X* X IF( FIRST ) THEN X FIRST = .FALSE. X ONE = 1 X* X* LBETA, LIEEE1, LT and LRND are the local values of BETA, X* IEEE1, T and RND. X* X* Throughout this routine we use the function DLAMC3 to ensure X* that relevant values are stored and not held in registers, or X* are not affected by optimizers. X* X* Compute a = 2.0**m with the smallest positive integer m such X* that X* X* fl( a + 1.0 ) = a. X* X A = 1 X C = 1 X* X*+ WHILE( C.EQ.ONE )LOOP X 10 CONTINUE X IF( C.EQ.ONE ) THEN X A = 2*A X C = DLAMC3( A, ONE ) X C = DLAMC3( C, -A ) X GO TO 10 X END IF X*+ END WHILE X* X* Now compute b = 2.0**m with the smallest positive integer m X* such that X* X* fl( a + b ) .gt. a. X* X B = 1 X C = DLAMC3( A, B ) X* X*+ WHILE( C.EQ.A )LOOP X 20 CONTINUE X IF( C.EQ.A ) THEN X B = 2*B X C = DLAMC3( A, B ) X GO TO 20 X END IF X*+ END WHILE X* X* Now compute the base. a and c are neighbouring floating point X* numbers in the interval ( beta**t, beta**( t + 1 ) ) and so X* their difference is beta. Adding 0.25 to c is to ensure that it X* is truncated to beta and not ( beta - 1 ). X* X QTR = ONE / 4 X SAVEC = C X C = DLAMC3( C, -A ) X LBETA = C + QTR X* X* Now determine whether rounding or chopping occurs, by adding a X* bit less than beta/2 and a bit more than beta/2 to a. X* X B = LBETA X F = DLAMC3( B / 2, -B / 100 ) X C = DLAMC3( F, A ) X IF( C.EQ.A ) THEN X LRND = .TRUE. X ELSE X LRND = .FALSE. X END IF X F = DLAMC3( B / 2, B / 100 ) X C = DLAMC3( F, A ) X IF( ( LRND ) .AND. ( C.EQ.A ) ) X $ LRND = .FALSE. X* X* Try and decide whether rounding is done in the IEEE 'round to X* nearest' style. B/2 is half a unit in the last place of the two X* numbers A and SAVEC. Furthermore, A is even, i.e. has last bit X* zero, and SAVEC is odd. Thus adding B/2 to A should not change X* A, but adding B/2 to SAVEC should change SAVEC. X* X T1 = DLAMC3( B / 2, A ) X T2 = DLAMC3( B / 2, SAVEC ) X LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. LRND X* X* Now find the mantissa, t. It should be the integer part of X* log to the base beta of a, however it is safer to determine t X* by powering. So we find t as the smallest positive integer for X* which X* X* fl( beta**t + 1.0 ) = 1.0. X* X LT = 0 X A = 1 X C = 1 X* X*+ WHILE( C.EQ.ONE )LOOP X 30 CONTINUE X IF( C.EQ.ONE ) THEN X LT = LT + 1 X A = A*LBETA X C = DLAMC3( A, ONE ) X C = DLAMC3( C, -A ) X GO TO 30 X END IF X*+ END WHILE X* X END IF X* X BETA = LBETA X T = LT X RND = LRND X IEEE1 = LIEEE1 X RETURN X* X* End of DLAMC1 X* X END X* X************************************************************************ X* X SUBROUTINE DLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX ) X* X* -- LAPACK auxiliary routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* October 31, 1992 X* X* .. Scalar Arguments .. X LOGICAL RND X INTEGER BETA, EMAX, EMIN, T X DOUBLE PRECISION EPS, RMAX, RMIN X* .. X* X* Purpose X* ======= X* X* DLAMC2 determines the machine parameters specified in its argument X* list. X* X* Arguments X* ========= X* X* BETA (output) INTEGER X* The base of the machine. X* X* T (output) INTEGER X* The number of ( BETA ) digits in the mantissa. X* X* RND (output) LOGICAL X* Specifies whether proper rounding ( RND = .TRUE. ) or X* chopping ( RND = .FALSE. ) occurs in addition. This may not X* be a reliable guide to the way in which the machine performs X* its arithmetic. X* X* EPS (output) DOUBLE PRECISION X* The smallest positive number such that X* X* fl( 1.0 - EPS ) .LT. 1.0, X* X* where fl denotes the computed value. X* X* EMIN (output) INTEGER X* The minimum exponent before (gradual) underflow occurs. X* X* RMIN (output) DOUBLE PRECISION X* The smallest normalized number for the machine, given by X* BASE**( EMIN - 1 ), where BASE is the floating point value X* of BETA. X* X* EMAX (output) INTEGER X* The maximum exponent before overflow occurs. X* X* RMAX (output) DOUBLE PRECISION X* The largest positive number for the machine, given by X* BASE**EMAX * ( 1 - EPS ), where BASE is the floating point X* value of BETA. X* X* Further Details X* =============== X* X* The computation of EPS is based on a routine PARANOIA by X* W. Kahan of the University of California at Berkeley. X* X* ===================================================================== X* X* .. Local Scalars .. X LOGICAL FIRST, IEEE, IWARN, LIEEE1, LRND X INTEGER GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT, X $ NGNMIN, NGPMIN X DOUBLE PRECISION A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE, X $ SIXTH, SMALL, THIRD, TWO, ZERO X* .. X* .. External Functions .. X DOUBLE PRECISION DLAMC3 X EXTERNAL DLAMC3 X* .. X* .. External Subroutines .. X EXTERNAL DLAMC1, DLAMC4, DLAMC5 X* .. X* .. Intrinsic Functions .. X INTRINSIC ABS, MAX, MIN X* .. X* .. Save statement .. X SAVE FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX, X $ LRMIN, LT X* .. X* .. Data statements .. X DATA FIRST / .TRUE. / , IWARN / .FALSE. / X* .. X* .. Executable Statements .. X* X IF( FIRST ) THEN X FIRST = .FALSE. X ZERO = 0 X ONE = 1 X TWO = 2 X* X* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of X* BETA, T, RND, EPS, EMIN and RMIN. X* X* Throughout this routine we use the function DLAMC3 to ensure X* that relevant values are stored and not held in registers, or X* are not affected by optimizers. X* X* DLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1. X* X CALL DLAMC1( LBETA, LT, LRND, LIEEE1 ) X* X* Start to find EPS. X* X B = LBETA X A = B**( -LT ) X LEPS = A X* X* Try some tricks to see whether or not this is the correct EPS. X* X B = TWO / 3 X HALF = ONE / 2 X SIXTH = DLAMC3( B, -HALF ) X THIRD = DLAMC3( SIXTH, SIXTH ) X B = DLAMC3( THIRD, -HALF ) X B = DLAMC3( B, SIXTH ) X B = ABS( B ) X IF( B.LT.LEPS ) X $ B = LEPS X* X LEPS = 1 X* X*+ WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP X 10 CONTINUE X IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN X LEPS = B X C = DLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) ) X C = DLAMC3( HALF, -C ) X B = DLAMC3( HALF, C ) X C = DLAMC3( HALF, -B ) X B = DLAMC3( HALF, C ) X GO TO 10 X END IF X*+ END WHILE X* X IF( A.LT.LEPS ) X $ LEPS = A X* X* Computation of EPS complete. X* X* Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)). X* Keep dividing A by BETA until (gradual) underflow occurs. This X* is detected when we cannot recover the previous A. X* X RBASE = ONE / LBETA X SMALL = ONE X DO 20 I = 1, 3 X SMALL = DLAMC3( SMALL*RBASE, ZERO ) X 20 CONTINUE X A = DLAMC3( ONE, SMALL ) X CALL DLAMC4( NGPMIN, ONE, LBETA ) X CALL DLAMC4( NGNMIN, -ONE, LBETA ) X CALL DLAMC4( GPMIN, A, LBETA ) X CALL DLAMC4( GNMIN, -A, LBETA ) X IEEE = .FALSE. X* X IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN X IF( NGPMIN.EQ.GPMIN ) THEN X LEMIN = NGPMIN X* ( Non twos-complement machines, no gradual underflow; X* e.g., VAX ) X ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN X LEMIN = NGPMIN - 1 + LT X IEEE = .TRUE. X* ( Non twos-complement machines, with gradual underflow; X* e.g., IEEE standard followers ) X ELSE X LEMIN = MIN( NGPMIN, GPMIN ) X* ( A guess; no known machine ) X IWARN = .TRUE. X END IF X* X ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN X IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN X LEMIN = MAX( NGPMIN, NGNMIN ) X* ( Twos-complement machines, no gradual underflow; X* e.g., CYBER 205 ) X ELSE X LEMIN = MIN( NGPMIN, NGNMIN ) X* ( A guess; no known machine ) X IWARN = .TRUE. X END IF X* X ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND. X $ ( GPMIN.EQ.GNMIN ) ) THEN X IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN X LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT X* ( Twos-complement machines with gradual underflow; X* no known machine ) X ELSE X LEMIN = MIN( NGPMIN, NGNMIN ) X* ( A guess; no known machine ) X IWARN = .TRUE. X END IF X* X ELSE X LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN ) X* ( A guess; no known machine ) X IWARN = .TRUE. X END IF X*** X* Comment out this if block if EMIN is ok X IF( IWARN ) THEN X FIRST = .TRUE. X WRITE( 6, FMT = 9999 )LEMIN X END IF X*** X* X* Assume IEEE arithmetic if we found denormalised numbers above, X* or if arithmetic seems to round in the IEEE style, determined X* in routine DLAMC1. A true IEEE machine should have both things X* true; however, faulty machines may have one or the other. X* X IEEE = IEEE .OR. LIEEE1 X* X* Compute RMIN by successive division by BETA. We could compute X* RMIN as BASE**( EMIN - 1 ), but some machines underflow during X* this computation. X* X LRMIN = 1 X DO 30 I = 1, 1 - LEMIN X LRMIN = DLAMC3( LRMIN*RBASE, ZERO ) X 30 CONTINUE X* X* Finally, call DLAMC5 to compute EMAX and RMAX. X* X CALL DLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX ) X END IF X* X BETA = LBETA X T = LT X RND = LRND X EPS = LEPS X EMIN = LEMIN X RMIN = LRMIN X EMAX = LEMAX X RMAX = LRMAX X* X RETURN X* X 9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-', X $ ' EMIN = ', I8, / X $ ' If, after inspection, the value EMIN looks', X $ ' acceptable please comment out ', X $ / ' the IF block as marked within the code of routine', X $ ' DLAMC2,', / ' otherwise supply EMIN explicitly.', / ) X* X* End of DLAMC2 X* X END X* X************************************************************************ X* X DOUBLE PRECISION FUNCTION DLAMC3( A, B ) X* X* -- LAPACK auxiliary routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* October 31, 1992 X* X* .. Scalar Arguments .. X DOUBLE PRECISION A, B X* .. X* X* Purpose X* ======= X* X* DLAMC3 is intended to force A and B to be stored prior to doing X* the addition of A and B , for use in situations where optimizers X* might hold one of these in a register. X* X* Arguments X* ========= X* X* A, B (input) DOUBLE PRECISION X* The values A and B. X* X* ===================================================================== X* X* .. Executable Statements .. X* X DLAMC3 = A + B X* X RETURN X* X* End of DLAMC3 X* X END X* X************************************************************************ X* X SUBROUTINE DLAMC4( EMIN, START, BASE ) X* X* -- LAPACK auxiliary routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* October 31, 1992 X* X* .. Scalar Arguments .. X INTEGER BASE, EMIN X DOUBLE PRECISION START X* .. X* X* Purpose X* ======= X* X* DLAMC4 is a service routine for DLAMC2. X* X* Arguments X* ========= X* X* EMIN (output) EMIN X* The minimum exponent before (gradual) underflow, computed by X* setting A = START and dividing by BASE until the previous A X* can not be recovered. X* X* START (input) DOUBLE PRECISION X* The starting point for determining EMIN. X* X* BASE (input) INTEGER X* The base of the machine. X* X* ===================================================================== X* X* .. Local Scalars .. X INTEGER I X DOUBLE PRECISION A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO X* .. X* .. External Functions .. X DOUBLE PRECISION DLAMC3 X EXTERNAL DLAMC3 X* .. X* .. Executable Statements .. X* X A = START X ONE = 1 X RBASE = ONE / BASE X ZERO = 0 X EMIN = 1 X B1 = DLAMC3( A*RBASE, ZERO ) X C1 = A X C2 = A X D1 = A X D2 = A X*+ WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND. X* $ ( D1.EQ.A ).AND.( D2.EQ.A ) )LOOP X 10 CONTINUE X IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND. X $ ( D2.EQ.A ) ) THEN X EMIN = EMIN - 1 X A = B1 X B1 = DLAMC3( A / BASE, ZERO ) X C1 = DLAMC3( B1*BASE, ZERO ) X D1 = ZERO X DO 20 I = 1, BASE X D1 = D1 + B1 X 20 CONTINUE X B2 = DLAMC3( A*RBASE, ZERO ) X C2 = DLAMC3( B2 / RBASE, ZERO ) X D2 = ZERO X DO 30 I = 1, BASE X D2 = D2 + B2 X 30 CONTINUE X GO TO 10 X END IF X*+ END WHILE X* X RETURN X* X* End of DLAMC4 X* X END X* X************************************************************************ X* X SUBROUTINE DLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX ) X* X* -- LAPACK auxiliary routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* October 31, 1992 X* X* .. Scalar Arguments .. X LOGICAL IEEE X INTEGER BETA, EMAX, EMIN, P X DOUBLE PRECISION RMAX X* .. X* X* Purpose X* ======= X* X* DLAMC5 attempts to compute RMAX, the largest machine floating-point X* number, without overflow. It assumes that EMAX + abs(EMIN) sum X* approximately to a power of 2. It will fail on machines where this X* assumption does not hold, for example, the Cyber 205 (EMIN = -28625, X* EMAX = 28718). It will also fail if the value supplied for EMIN is X* too large (i.e. too close to zero), probably with overflow. X* X* Arguments X* ========= X* X* BETA (input) INTEGER X* The base of floating-point arithmetic. X* X* P (input) INTEGER X* The number of base BETA digits in the mantissa of a X* floating-point value. X* X* EMIN (input) INTEGER X* The minimum exponent before (gradual) underflow. X* X* IEEE (input) LOGICAL X* A logical flag specifying whether or not the arithmetic X* system is thought to comply with the IEEE standard. X* X* EMAX (output) INTEGER X* The largest exponent before overflow X* X* RMAX (output) DOUBLE PRECISION X* The largest machine floating-point number. X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ZERO, ONE X PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) X* .. X* .. Local Scalars .. X INTEGER EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP X DOUBLE PRECISION OLDY, RECBAS, Y, Z X* .. X* .. External Functions .. X DOUBLE PRECISION DLAMC3 X EXTERNAL DLAMC3 X* .. X* .. Intrinsic Functions .. X INTRINSIC MOD X* .. X* .. Executable Statements .. X* X* First compute LEXP and UEXP, two powers of 2 that bound X* abs(EMIN). We then assume that EMAX + abs(EMIN) will sum X* approximately to the bound that is closest to abs(EMIN). X* (EMAX is the exponent of the required number RMAX). X* X LEXP = 1 X EXBITS = 1 X 10 CONTINUE X TRY = LEXP*2 X IF( TRY.LE.( -EMIN ) ) THEN X LEXP = TRY X EXBITS = EXBITS + 1 X GO TO 10 X END IF X IF( LEXP.EQ.-EMIN ) THEN X UEXP = LEXP X ELSE X UEXP = TRY X EXBITS = EXBITS + 1 X END IF X* X* Now -LEXP is less than or equal to EMIN, and -UEXP is greater X* than or equal to EMIN. EXBITS is the number of bits needed to X* store the exponent. X* X IF( ( UEXP+EMIN ).GT.( -LEXP-EMIN ) ) THEN X EXPSUM = 2*LEXP X ELSE X EXPSUM = 2*UEXP X END IF X* X* EXPSUM is the exponent range, approximately equal to X* EMAX - EMIN + 1 . X* X EMAX = EXPSUM + EMIN - 1 X NBITS = 1 + EXBITS + P X* X* NBITS is the total number of bits needed to store a X* floating-point number. X* X IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN X* X* Either there are an odd number of bits used to store a X* floating-point number, which is unlikely, or some bits are X* not used in the representation of numbers, which is possible, X* (e.g. Cray machines) or the mantissa has an implicit bit, X* (e.g. IEEE machines, Dec Vax machines), which is perhaps the X* most likely. We have to assume the last alternative. X* If this is true, then we need to reduce EMAX by one because X* there must be some way of representing zero in an implicit-bit X* system. On machines like Cray, we are reducing EMAX by one X* unnecessarily. X* X EMAX = EMAX - 1 X END IF X* X IF( IEEE ) THEN X* X* Assume we are on an IEEE machine which reserves one exponent X* for infinity and NaN. X* X EMAX = EMAX - 1 X END IF X* X* Now create RMAX, the largest machine number, which should X* be equal to (1.0 - BETA**(-P)) * BETA**EMAX . X* X* First compute 1.0 - BETA**(-P), being careful that the X* result is less than 1.0 . X* X RECBAS = ONE / BETA X Z = BETA - ONE X Y = ZERO X DO 20 I = 1, P X Z = Z*RECBAS X IF( Y.LT.ONE ) X $ OLDY = Y X Y = DLAMC3( Y, Z ) X 20 CONTINUE X IF( Y.GE.ONE ) X $ Y = OLDY X* X* Now multiply by BETA**EMAX to get RMAX. X* X DO 30 I = 1, EMAX X Y = DLAMC3( Y*BETA, ZERO ) X 30 CONTINUE X* X RMAX = Y X RETURN X* X* End of DLAMC5 X* X END X SUBROUTINE DLAE2( A, B, C, RT1, RT2 ) X* X* -- LAPACK auxiliary routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* October 31, 1992 X* X* .. Scalar Arguments .. X DOUBLE PRECISION A, B, C, RT1, RT2 X* .. X* X* Purpose X* ======= X* X* DLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix X* [ A B ] X* [ B C ]. X* On return, RT1 is the eigenvalue of larger absolute value, and RT2 X* is the eigenvalue of smaller absolute value. X* X* Arguments X* ========= X* X* A (input) DOUBLE PRECISION X* The (1,1) element of the 2-by-2 matrix. X* X* B (input) DOUBLE PRECISION X* The (1,2) and (2,1) elements of the 2-by-2 matrix. X* X* C (input) DOUBLE PRECISION X* The (2,2) element of the 2-by-2 matrix. X* X* RT1 (output) DOUBLE PRECISION X* The eigenvalue of larger absolute value. X* X* RT2 (output) DOUBLE PRECISION X* The eigenvalue of smaller absolute value. X* X* Further Details X* =============== X* X* RT1 is accurate to a few ulps barring over/underflow. X* X* RT2 may be inaccurate if there is massive cancellation in the X* determinant A*C-B*B; higher precision or correctly rounded or X* correctly truncated arithmetic would be needed to compute RT2 X* accurately in all cases. X* X* Overflow is possible only if RT1 is within a factor of 5 of overflow. X* Underflow is harmless if the input data is 0 or exceeds X* underflow_threshold / macheps. X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ONE X PARAMETER ( ONE = 1.0D0 ) X DOUBLE PRECISION TWO X PARAMETER ( TWO = 2.0D0 ) X DOUBLE PRECISION ZERO X PARAMETER ( ZERO = 0.0D0 ) X DOUBLE PRECISION HALF X PARAMETER ( HALF = 0.5D0 ) X* .. X* .. Local Scalars .. X DOUBLE PRECISION AB, ACMN, ACMX, ADF, DF, RT, SM, TB X* .. X* .. Intrinsic Functions .. X INTRINSIC ABS, SQRT X* .. X* .. Executable Statements .. X* X* Compute the eigenvalues X* X SM = A + C X DF = A - C X ADF = ABS( DF ) X TB = B + B X AB = ABS( TB ) X IF( ABS( A ).GT.ABS( C ) ) THEN X ACMX = A X ACMN = C X ELSE X ACMX = C X ACMN = A X END IF X IF( ADF.GT.AB ) THEN X RT = ADF*SQRT( ONE+( AB / ADF )**2 ) X ELSE IF( ADF.LT.AB ) THEN X RT = AB*SQRT( ONE+( ADF / AB )**2 ) X ELSE X* X* Includes case AB=ADF=0 X* X RT = AB*SQRT( TWO ) X END IF X IF( SM.LT.ZERO ) THEN X RT1 = HALF*( SM-RT ) X* X* Order of execution important. X* To get fully accurate smaller eigenvalue, X* next line needs to be executed in higher precision. X* X RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B X ELSE IF( SM.GT.ZERO ) THEN X RT1 = HALF*( SM+RT ) X* X* Order of execution important. X* To get fully accurate smaller eigenvalue, X* next line needs to be executed in higher precision. X* X RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B X ELSE X* X* Includes case RT1 = RT2 = 0 X* X RT1 = HALF*RT X RT2 = -HALF*RT X END IF X RETURN X* X* End of DLAE2 X* X END X SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) X* X* -- LAPACK auxiliary routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* October 31, 1992 X* X* .. Scalar Arguments .. X DOUBLE PRECISION A, B, C, CS1, RT1, RT2, SN1 X* .. X* X* Purpose X* ======= X* X* DLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix X* [ A B ] X* [ B C ]. X* On return, RT1 is the eigenvalue of larger absolute value, RT2 is the X* eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right X* eigenvector for RT1, giving the decomposition X* X* [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ] X* [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ]. X* X* Arguments X* ========= X* X* A (input) DOUBLE PRECISION X* The (1,1) element of the 2-by-2 matrix. X* X* B (input) DOUBLE PRECISION X* The (1,2) element and the conjugate of the (2,1) element of X* the 2-by-2 matrix. X* X* C (input) DOUBLE PRECISION X* The (2,2) element of the 2-by-2 matrix. X* X* RT1 (output) DOUBLE PRECISION X* The eigenvalue of larger absolute value. X* X* RT2 (output) DOUBLE PRECISION X* The eigenvalue of smaller absolute value. X* X* CS1 (output) DOUBLE PRECISION X* SN1 (output) DOUBLE PRECISION X* The vector (CS1, SN1) is a unit right eigenvector for RT1. X* X* Further Details X* =============== X* X* RT1 is accurate to a few ulps barring over/underflow. X* X* RT2 may be inaccurate if there is massive cancellation in the X* determinant A*C-B*B; higher precision or correctly rounded or X* correctly truncated arithmetic would be needed to compute RT2 X* accurately in all cases. X* X* CS1 and SN1 are accurate to a few ulps barring over/underflow. X* X* Overflow is possible only if RT1 is within a factor of 5 of overflow. X* Underflow is harmless if the input data is 0 or exceeds X* underflow_threshold / macheps. X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ONE X PARAMETER ( ONE = 1.0D0 ) X DOUBLE PRECISION TWO X PARAMETER ( TWO = 2.0D0 ) X DOUBLE PRECISION ZERO X PARAMETER ( ZERO = 0.0D0 ) X DOUBLE PRECISION HALF X PARAMETER ( HALF = 0.5D0 ) X* .. X* .. Local Scalars .. X INTEGER SGN1, SGN2 X DOUBLE PRECISION AB, ACMN, ACMX, ACS, ADF, CS, CT, DF, RT, SM, X $ TB, TN X* .. X* .. Intrinsic Functions .. X INTRINSIC ABS, SQRT X* .. X* .. Executable Statements .. X* X* Compute the eigenvalues X* X SM = A + C X DF = A - C X ADF = ABS( DF ) X TB = B + B X AB = ABS( TB ) X IF( ABS( A ).GT.ABS( C ) ) THEN X ACMX = A X ACMN = C X ELSE X ACMX = C X ACMN = A X END IF X IF( ADF.GT.AB ) THEN X RT = ADF*SQRT( ONE+( AB / ADF )**2 ) X ELSE IF( ADF.LT.AB ) THEN X RT = AB*SQRT( ONE+( ADF / AB )**2 ) X ELSE X* X* Includes case AB=ADF=0 X* X RT = AB*SQRT( TWO ) X END IF X IF( SM.LT.ZERO ) THEN X RT1 = HALF*( SM-RT ) X SGN1 = -1 X* X* Order of execution important. X* To get fully accurate smaller eigenvalue, X* next line needs to be executed in higher precision. X* X RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B X ELSE IF( SM.GT.ZERO ) THEN X RT1 = HALF*( SM+RT ) X SGN1 = 1 X* X* Order of execution important. X* To get fully accurate smaller eigenvalue, X* next line needs to be executed in higher precision. X* X RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B X ELSE X* X* Includes case RT1 = RT2 = 0 X* X RT1 = HALF*RT X RT2 = -HALF*RT X SGN1 = 1 X END IF X* X* Compute the eigenvector X* X IF( DF.GE.ZERO ) THEN X CS = DF + RT X SGN2 = 1 X ELSE X CS = DF - RT X SGN2 = -1 X END IF X ACS = ABS( CS ) X IF( ACS.GT.AB ) THEN X CT = -TB / CS X SN1 = ONE / SQRT( ONE+CT*CT ) X CS1 = CT*SN1 X ELSE X IF( AB.EQ.ZERO ) THEN X CS1 = ONE X SN1 = ZERO X ELSE X TN = -CS / TB X CS1 = ONE / SQRT( ONE+TN*TN ) X SN1 = TN*CS1 X END IF X END IF X IF( SGN1.EQ.SGN2 ) THEN X TN = CS1 X CS1 = -SN1 X SN1 = TN X END IF X RETURN X* X* End of DLAEV2 X* X END X* X DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E ) X* X* -- LAPACK auxiliary routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* February 29, 1992 X* X* .. Scalar Arguments .. X CHARACTER NORM X INTEGER N X* .. X* .. Array Arguments .. X DOUBLE PRECISION D( * ), E( * ) X* .. X* X* Purpose X* ======= X* X* DLANST returns the value of the one norm, or the Frobenius norm, or X* the infinity norm, or the element of largest absolute value of a X* real symmetric tridiagonal matrix A. X* X* Description X* =========== X* X* DLANST returns the value X* X* DLANST = ( max(abs(A(i,j))), NORM = 'M' or 'm' X* ( X* ( norm1(A), NORM = '1', 'O' or 'o' X* ( X* ( normI(A), NORM = 'I' or 'i' X* ( X* ( normF(A), NORM = 'F', 'f', 'E' or 'e' X* X* where norm1 denotes the one norm of a matrix (maximum column sum), X* normI denotes the infinity norm of a matrix (maximum row sum) and X* normF denotes the Frobenius norm of a matrix (square root of sum of X* squares). Note that max(abs(A(i,j))) is not a matrix norm. X* X* Arguments X* ========= X* X* NORM (input) CHARACTER*1 X* Specifies the value to be returned in DLANST as described X* above. X* X* N (input) INTEGER X* The order of the matrix A. N >= 0. When N = 0, DLANST is X* set to zero. X* X* D (input) DOUBLE PRECISION array, dimension (N) X* The diagonal elements of A. X* X* E (input) DOUBLE PRECISION array, dimension (N-1) X* The (n-1) sub-diagonal or super-diagonal elements of A. X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ONE, ZERO X PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) X* .. X* .. Local Scalars .. X INTEGER I X DOUBLE PRECISION ANORM, SCALE, SUM X* .. X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. X* .. External Subroutines .. X EXTERNAL DLASSQ X* .. X* .. Intrinsic Functions .. X INTRINSIC ABS, MAX, SQRT X* .. X* .. Executable Statements .. X* X IF( N.LE.0 ) THEN X ANORM = ZERO X ELSE IF( LSAME( NORM, 'M' ) ) THEN X* X* Find max(abs(A(i,j))). X* X ANORM = ABS( D( N ) ) X DO 10 I = 1, N - 1 X ANORM = MAX( ANORM, ABS( D( I ) ) ) X ANORM = MAX( ANORM, ABS( E( I ) ) ) X 10 CONTINUE X ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' .OR. X $ LSAME( NORM, 'I' ) ) THEN X* X* Find norm1(A). X* X IF( N.EQ.1 ) THEN X ANORM = ABS( D( 1 ) ) X ELSE X ANORM = MAX( ABS( D( 1 ) )+ABS( E( 1 ) ), X $ ABS( E( N-1 ) )+ABS( D( N ) ) ) X DO 20 I = 2, N - 1 X ANORM = MAX( ANORM, ABS( D( I ) )+ABS( E( I ) )+ X $ ABS( E( I-1 ) ) ) X 20 CONTINUE X END IF X ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN X* X* Find normF(A). X* X SCALE = ZERO X SUM = ONE X IF( N.GT.1 ) THEN X CALL DLASSQ( N-1, E, 1, SCALE, SUM ) X SUM = 2*SUM X END IF X CALL DLASSQ( N, D, 1, SCALE, SUM ) X ANORM = SCALE*SQRT( SUM ) X END IF X* X DLANST = ANORM X RETURN X* X* End of DLANST X* X END X SUBROUTINE DLASRT( ID, N, D, INFO ) X* X* -- LAPACK routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* September 30, 1994 X* X* .. Scalar Arguments .. X CHARACTER ID X INTEGER INFO, N X* .. X* .. Array Arguments .. X DOUBLE PRECISION D( * ) X* .. X* X* Purpose X* ======= X* X* Sort the numbers in D in increasing order (if ID = 'I') or X* in decreasing order (if ID = 'D' ). X* X* Use Quick Sort, reverting to Insertion sort on arrays of X* size <= 20. Dimension of STACK limits N to about 2**32. X* X* Arguments X* ========= X* X* ID (input) CHARACTER*1 X* = 'I': sort D in increasing order; X* = 'D': sort D in decreasing order. X* X* N (input) INTEGER X* The length of the array D. X* X* D (input/output) DOUBLE PRECISION array, dimension (N) X* On entry, the array to be sorted. X* On exit, D has been sorted into increasing order X* (D(1) <= ... <= D(N) ) or into decreasing order X* (D(1) >= ... >= D(N) ), depending on ID. X* X* INFO (output) INTEGER X* = 0: successful exit X* < 0: if INFO = -i, the i-th argument had an illegal value X* X* ===================================================================== X* X* .. Parameters .. X INTEGER SELECT X PARAMETER ( SELECT = 20 ) X* .. X* .. Local Scalars .. X INTEGER DIR, ENDD, I, J, START, STKPNT X DOUBLE PRECISION D1, D2, D3, DMNMX, TMP X* .. X* .. Local Arrays .. X INTEGER STACK( 2, 32 ) X* .. X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. X* .. External Subroutines .. X EXTERNAL XERBLA X* .. X* .. Executable Statements .. X* X* Test the input paramters. X* X INFO = 0 X DIR = -1 X IF( LSAME( ID, 'D' ) ) THEN X DIR = 0 X ELSE IF( LSAME( ID, 'I' ) ) THEN X DIR = 1 X END IF X IF( DIR.EQ.-1 ) THEN X INFO = -1 X ELSE IF( N.LT.0 ) THEN X INFO = -2 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DLASRT', -INFO ) X RETURN X END IF X* X* Quick return if possible X* X IF( N.LE.1 ) X $ RETURN X* X STKPNT = 1 X STACK( 1, 1 ) = 1 X STACK( 2, 1 ) = N X 10 CONTINUE X START = STACK( 1, STKPNT ) X ENDD = STACK( 2, STKPNT ) X STKPNT = STKPNT - 1 X IF( ENDD-START.LE.SELECT .AND. ENDD-START.GT.0 ) THEN X* X* Do Insertion sort on D( START:ENDD ) X* X IF( DIR.EQ.0 ) THEN X* X* Sort into decreasing order X* X DO 30 I = START + 1, ENDD X DO 20 J = I, START + 1, -1 X IF( D( J ).GT.D( J-1 ) ) THEN X DMNMX = D( J ) X D( J ) = D( J-1 ) X D( J-1 ) = DMNMX X ELSE X GO TO 30 X END IF X 20 CONTINUE X 30 CONTINUE X* X ELSE X* X* Sort into increasing order X* X DO 50 I = START + 1, ENDD X DO 40 J = I, START + 1, -1 X IF( D( J ).LT.D( J-1 ) ) THEN X DMNMX = D( J ) X D( J ) = D( J-1 ) X D( J-1 ) = DMNMX X ELSE X GO TO 50 X END IF X 40 CONTINUE X 50 CONTINUE X* X END IF X* X ELSE IF( ENDD-START.GT.SELECT ) THEN X* X* Partition D( START:ENDD ) and stack parts, largest one first X* X* Choose partition entry as median of 3 X* X D1 = D( START ) X D2 = D( ENDD ) X I = ( START+ENDD ) / 2 X D3 = D( I ) X IF( D1.LT.D2 ) THEN X IF( D3.LT.D1 ) THEN X DMNMX = D1 X ELSE IF( D3.LT.D2 ) THEN X DMNMX = D3 X ELSE X DMNMX = D2 X END IF X ELSE X IF( D3.LT.D2 ) THEN X DMNMX = D2 X ELSE IF( D3.LT.D1 ) THEN X DMNMX = D3 X ELSE X DMNMX = D1 X END IF X END IF X* X IF( DIR.EQ.0 ) THEN X* X* Sort into decreasing order X* X I = START - 1 X J = ENDD + 1 X 60 CONTINUE X 70 CONTINUE X J = J - 1 X IF( D( J ).LT.DMNMX ) X $ GO TO 70 X 80 CONTINUE X I = I + 1 X IF( D( I ).GT.DMNMX ) X $ GO TO 80 X IF( I.LT.J ) THEN X TMP = D( I ) X D( I ) = D( J ) X D( J ) = TMP X GO TO 60 X END IF X IF( J-START.GT.ENDD-J-1 ) THEN X STKPNT = STKPNT + 1 X STACK( 1, STKPNT ) = START X STACK( 2, STKPNT ) = J X STKPNT = STKPNT + 1 X STACK( 1, STKPNT ) = J + 1 X STACK( 2, STKPNT ) = ENDD X ELSE X STKPNT = STKPNT + 1 X STACK( 1, STKPNT ) = J + 1 X STACK( 2, STKPNT ) = ENDD X STKPNT = STKPNT + 1 X STACK( 1, STKPNT ) = START X STACK( 2, STKPNT ) = J X END IF X ELSE X* X* Sort into increasing order X* X I = START - 1 X J = ENDD + 1 X 90 CONTINUE X 100 CONTINUE X J = J - 1 X IF( D( J ).GT.DMNMX ) X $ GO TO 100 X 110 CONTINUE X I = I + 1 X IF( D( I ).LT.DMNMX ) X $ GO TO 110 X IF( I.LT.J ) THEN X TMP = D( I ) X D( I ) = D( J ) X D( J ) = TMP X GO TO 90 X END IF X IF( J-START.GT.ENDD-J-1 ) THEN X STKPNT = STKPNT + 1 X STACK( 1, STKPNT ) = START X STACK( 2, STKPNT ) = J X STKPNT = STKPNT + 1 X STACK( 1, STKPNT ) = J + 1 X STACK( 2, STKPNT ) = ENDD X ELSE X STKPNT = STKPNT + 1 X STACK( 1, STKPNT ) = J + 1 X STACK( 2, STKPNT ) = ENDD X STKPNT = STKPNT + 1 X STACK( 1, STKPNT ) = START X STACK( 2, STKPNT ) = J X END IF X END IF X END IF X IF( STKPNT.GT.0 ) X $ GO TO 10 X RETURN X* X* End of DLASRT X* X END X* X SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, X $ WORK, LWORK, INFO ) X* X* -- LAPACK routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* September 30, 1994 X* X* .. Scalar Arguments .. X CHARACTER SIDE, TRANS X INTEGER INFO, K, LDA, LDC, LWORK, M, N X* .. X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), X $ WORK( LWORK ) X* .. X* X* Purpose X* ======= X* X* DORMQR overwrites the general real M-by-N matrix C with X* X* SIDE = 'L' SIDE = 'R' X* TRANS = 'N': Q * C C * Q X* TRANS = 'T': Q**T * C C * Q**T X* X* where Q is a real orthogonal matrix defined as the product of k X* elementary reflectors X* X* Q = H(1) H(2) . . . H(k) X* X* as returned by DGEQRF. Q is of order M if SIDE = 'L' and of order N X* if SIDE = 'R'. X* X* Arguments X* ========= X* X* SIDE (input) CHARACTER*1 X* = 'L': apply Q or Q**T from the Left; X* = 'R': apply Q or Q**T from the Right. X* X* TRANS (input) CHARACTER*1 X* = 'N': No transpose, apply Q; X* = 'T': Transpose, apply Q**T. X* X* M (input) INTEGER X* The number of rows of the matrix C. M >= 0. X* X* N (input) INTEGER X* The number of columns of the matrix C. N >= 0. X* X* K (input) INTEGER X* The number of elementary reflectors whose product defines X* the matrix Q. X* If SIDE = 'L', M >= K >= 0; X* if SIDE = 'R', N >= K >= 0. X* X* A (input) DOUBLE PRECISION array, dimension (LDA,K) X* The i-th column must contain the vector which defines the X* elementary reflector H(i), for i = 1,2,...,k, as returned by X* DGEQRF in the first k columns of its array argument A. X* A is modified by the routine but restored on exit. X* X* LDA (input) INTEGER X* The leading dimension of the array A. X* If SIDE = 'L', LDA >= max(1,M); X* if SIDE = 'R', LDA >= max(1,N). X* X* TAU (input) DOUBLE PRECISION array, dimension (K) X* TAU(i) must contain the scalar factor of the elementary X* reflector H(i), as returned by DGEQRF. X* X* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) X* On entry, the M-by-N matrix C. X* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. X* X* LDC (input) INTEGER X* The leading dimension of the array C. LDC >= max(1,M). X* X* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) X* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. X* X* LWORK (input) INTEGER X* The dimension of the array WORK. X* If SIDE = 'L', LWORK >= max(1,N); X* if SIDE = 'R', LWORK >= max(1,M). X* For optimum performance LWORK >= N*NB if SIDE = 'L', and X* LWORK >= M*NB if SIDE = 'R', where NB is the optimal X* blocksize. X* X* INFO (output) INTEGER X* = 0: successful exit X* < 0: if INFO = -i, the i-th argument had an illegal value X* X* ===================================================================== X* X* .. Parameters .. X INTEGER NBMAX, LDT X PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) X* .. X* .. Local Scalars .. X LOGICAL LEFT, NOTRAN X INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK, X $ MI, NB, NBMIN, NI, NQ, NW X* .. X* .. Local Arrays .. X DOUBLE PRECISION T( LDT, NBMAX ) X* .. X* .. External Functions .. X LOGICAL LSAME X INTEGER ILAENV X EXTERNAL LSAME, ILAENV X* .. X* .. External Subroutines .. X EXTERNAL DLARFB, DLARFT, DORM2R, XERBLA X* .. X* .. Intrinsic Functions .. X INTRINSIC MAX, MIN X* .. X* .. Executable Statements .. X* X* Test the input arguments X* X INFO = 0 X LEFT = LSAME( SIDE, 'L' ) X NOTRAN = LSAME( TRANS, 'N' ) X* X* NQ is the order of Q and NW is the minimum dimension of WORK X* X IF( LEFT ) THEN X NQ = M X NW = N X ELSE X NQ = N X NW = M X END IF X IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN X INFO = -1 X ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN X INFO = -2 X ELSE IF( M.LT.0 ) THEN X INFO = -3 X ELSE IF( N.LT.0 ) THEN X INFO = -4 X ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN X INFO = -5 X ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN X INFO = -7 X ELSE IF( LDC.LT.MAX( 1, M ) ) THEN X INFO = -10 X ELSE IF( LWORK.LT.MAX( 1, NW ) ) THEN X INFO = -12 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DORMQR', -INFO ) X RETURN X END IF X* X* Quick return if possible X* X IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN X WORK( 1 ) = 1 X RETURN X END IF X* X* Determine the block size. NB may be at most NBMAX, where NBMAX X* is used to define the local array T. X* X NB = MIN( NBMAX, ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N, K, X $ -1 ) ) X NBMIN = 2 X LDWORK = NW X IF( NB.GT.1 .AND. NB.LT.K ) THEN X IWS = NW*NB X IF( LWORK.LT.IWS ) THEN X NB = LWORK / LDWORK X NBMIN = MAX( 2, ILAENV( 2, 'DORMQR', SIDE // TRANS, M, N, K, X $ -1 ) ) X END IF X ELSE X IWS = NW X END IF X* X IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN X* X* Use unblocked code X* X CALL DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, X $ IINFO ) X ELSE X* X* Use blocked code X* X IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. X $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN X I1 = 1 X I2 = K X I3 = NB X ELSE X I1 = ( ( K-1 ) / NB )*NB + 1 X I2 = 1 X I3 = -NB X END IF X* X IF( LEFT ) THEN X NI = N X JC = 1 X ELSE X MI = M X IC = 1 X END IF X* X DO 10 I = I1, I2, I3 X IB = MIN( NB, K-I+1 ) X* X* Form the triangular factor of the block reflector X* H = H(i) H(i+1) . . . H(i+ib-1) X* X CALL DLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ), X $ LDA, TAU( I ), T, LDT ) X IF( LEFT ) THEN X* X* H or H' is applied to C(i:m,1:n) X* X MI = M - I + 1 X IC = I X ELSE X* X* H or H' is applied to C(1:m,i:n) X* X NI = N - I + 1 X JC = I X END IF X* X* Apply H or H' X* X CALL DLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI, X $ IB, A( I, I ), LDA, T, LDT, C( IC, JC ), LDC, X $ WORK, LDWORK ) X 10 CONTINUE X END IF X WORK( 1 ) = IWS X RETURN X* X* End of DORMQR X* X END X SUBROUTINE DLAEBZ( IJOB, NITMAX, N, MMAX, MINP, NBMIN, ABSTOL, X $ RELTOL, PIVMIN, D, E, E2, NVAL, AB, C, MOUT, X $ NAB, WORK, IWORK, INFO ) X* X* -- LAPACK auxiliary routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* September 30, 1994 X* X* .. Scalar Arguments .. X INTEGER IJOB, INFO, MINP, MMAX, MOUT, N, NBMIN, NITMAX X DOUBLE PRECISION ABSTOL, PIVMIN, RELTOL X* .. X* .. Array Arguments .. X INTEGER IWORK( * ), NAB( MMAX, * ), NVAL( * ) X DOUBLE PRECISION AB( MMAX, * ), C( * ), D( * ), E( * ), E2( * ), X $ WORK( * ) X* .. X* X* Purpose X* ======= X* X* DLAEBZ contains the iteration loops which compute and use the X* function N(w), which is the count of eigenvalues of a symmetric X* tridiagonal matrix T less than or equal to its argument w. It X* performs a choice of two types of loops: X* X* IJOB=1, followed by X* IJOB=2: It takes as input a list of intervals and returns a list of X* sufficiently small intervals whose union contains the same X* eigenvalues as the union of the original intervals. X* The input intervals are (AB(j,1),AB(j,2)], j=1,...,MINP. X* The output interval (AB(j,1),AB(j,2)] will contain X* eigenvalues NAB(j,1)+1,...,NAB(j,2), where 1 <= j <= MOUT. X* X* IJOB=3: It performs a binary search in each input interval X* (AB(j,1),AB(j,2)] for a point w(j) such that X* N(w(j))=NVAL(j), and uses C(j) as the starting point of X* the search. If such a w(j) is found, then on output X* AB(j,1)=AB(j,2)=w. If no such w(j) is found, then on output X* (AB(j,1),AB(j,2)] will be a small interval containing the X* point where N(w) jumps through NVAL(j), unless that point X* lies outside the initial interval. X* X* Note that the intervals are in all cases half-open intervals, X* i.e., of the form (a,b] , which includes b but not a . X* X* To avoid underflow, the matrix should be scaled so that its largest X* element is no greater than overflow**(1/2) * underflow**(1/4) X* in absolute value. To assure the most accurate computation X* of small eigenvalues, the matrix should be scaled to be X* not much smaller than that, either. X* X* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal X* Matrix", Report CS41, Computer Science Dept., Stanford X* University, July 21, 1966 X* X* Note: the arguments are, in general, *not* checked for unreasonable X* values. X* X* Arguments X* ========= X* X* IJOB (input) INTEGER X* Specifies what is to be done: X* = 1: Compute NAB for the initial intervals. X* = 2: Perform bisection iteration to find eigenvalues of T. X* = 3: Perform bisection iteration to invert N(w), i.e., X* to find a point which has a specified number of X* eigenvalues of T to its left. X* Other values will cause DLAEBZ to return with INFO=-1. X* X* NITMAX (input) INTEGER X* The maximum number of "levels" of bisection to be X* performed, i.e., an interval of width W will not be made X* smaller than 2^(-NITMAX) * W. If not all intervals X* have converged after NITMAX iterations, then INFO is set X* to the number of non-converged intervals. X* X* N (input) INTEGER X* The dimension n of the tridiagonal matrix T. It must be at X* least 1. X* X* MMAX (input) INTEGER X* The maximum number of intervals. If more than MMAX intervals X* are generated, then DLAEBZ will quit with INFO=MMAX+1. X* X* MINP (input) INTEGER X* The initial number of intervals. It may not be greater than X* MMAX. X* X* NBMIN (input) INTEGER X* The smallest number of intervals that should be processed X* using a vector loop. If zero, then only the scalar loop X* will be used. X* X* ABSTOL (input) DOUBLE PRECISION X* The minimum (absolute) width of an interval. When an X* interval is narrower than ABSTOL, or than RELTOL times the X* larger (in magnitude) endpoint, then it is considered to be X* sufficiently small, i.e., converged. This must be at least X* zero. X* X* RELTOL (input) DOUBLE PRECISION X* The minimum relative width of an interval. When an interval X* is narrower than ABSTOL, or than RELTOL times the larger (in X* magnitude) endpoint, then it is considered to be X* sufficiently small, i.e., converged. Note: this should X* always be at least radix*machine epsilon. X* X* PIVMIN (input) DOUBLE PRECISION X* The minimum absolute value of a "pivot" in the Sturm X* sequence loop. This *must* be at least max |e(j)**2| * X* safe_min and at least safe_min, where safe_min is at least X* the smallest number that can divide one without overflow. X* X* D (input) DOUBLE PRECISION array, dimension (N) X* The diagonal elements of the tridiagonal matrix T. X* X* E (input) DOUBLE PRECISION array, dimension (N) X* The offdiagonal elements of the tridiagonal matrix T in X* positions 1 through N-1. E(N) is arbitrary. X* X* E2 (input) DOUBLE PRECISION array, dimension (N) X* The squares of the offdiagonal elements of the tridiagonal X* matrix T. E2(N) is ignored. X* X* NVAL (input/output) INTEGER array, dimension (MINP) X* If IJOB=1 or 2, not referenced. X* If IJOB=3, the desired values of N(w). The elements of NVAL X* will be reordered to correspond with the intervals in AB. X* Thus, NVAL(j) on output will not, in general be the same as X* NVAL(j) on input, but it will correspond with the interval X* (AB(j,1),AB(j,2)] on output. X* X* AB (input/output) DOUBLE PRECISION array, dimension (MMAX,2) X* The endpoints of the intervals. AB(j,1) is a(j), the left X* endpoint of the j-th interval, and AB(j,2) is b(j), the X* right endpoint of the j-th interval. The input intervals X* will, in general, be modified, split, and reordered by the X* calculation. X* X* C (input/output) DOUBLE PRECISION array, dimension (MMAX) X* If IJOB=1, ignored. X* If IJOB=2, workspace. X* If IJOB=3, then on input C(j) should be initialized to the X* first search point in the binary search. X* X* MOUT (output) INTEGER X* If IJOB=1, the number of eigenvalues in the intervals. X* If IJOB=2 or 3, the number of intervals output. X* If IJOB=3, MOUT will equal MINP. X* X* NAB (input/output) INTEGER array, dimension (MMAX,2) X* If IJOB=1, then on output NAB(i,j) will be set to N(AB(i,j)). X* If IJOB=2, then on input, NAB(i,j) should be set. It must X* satisfy the condition: X* N(AB(i,1)) <= NAB(i,1) <= NAB(i,2) <= N(AB(i,2)), X* which means that in interval i only eigenvalues X* NAB(i,1)+1,...,NAB(i,2) will be considered. Usually, X* NAB(i,j)=N(AB(i,j)), from a previous call to DLAEBZ with X* IJOB=1. X* On output, NAB(i,j) will contain X* max(na(k),min(nb(k),N(AB(i,j)))), where k is the index of X* the input interval that the output interval X* (AB(j,1),AB(j,2)] came from, and na(k) and nb(k) are the X* the input values of NAB(k,1) and NAB(k,2). X* If IJOB=3, then on output, NAB(i,j) contains N(AB(i,j)), X* unless N(w) > NVAL(i) for all search points w , in which X* case NAB(i,1) will not be modified, i.e., the output X* value will be the same as the input value (modulo X* reorderings -- see NVAL and AB), or unless N(w) < NVAL(i) X* for all search points w , in which case NAB(i,2) will X* not be modified. Normally, NAB should be set to some X* distinctive value(s) before DLAEBZ is called. X* X* WORK (workspace) DOUBLE PRECISION array, dimension (MMAX) X* Workspace. X* X* IWORK (workspace) INTEGER array, dimension (MMAX) X* Workspace. X* X* INFO (output) INTEGER X* = 0: All intervals converged. X* = 1--MMAX: The last INFO intervals did not converge. X* = MMAX+1: More than MMAX intervals were generated. X* X* Further Details X* =============== X* X* This routine is intended to be called only by other LAPACK X* routines, thus the interface is less user-friendly. It is intended X* for two purposes: X* X* (a) finding eigenvalues. In this case, DLAEBZ should have one or X* more initial intervals set up in AB, and DLAEBZ should be called X* with IJOB=1. This sets up NAB, and also counts the eigenvalues. X* Intervals with no eigenvalues would usually be thrown out at X* this point. Also, if not all the eigenvalues in an interval i X* are desired, NAB(i,1) can be increased or NAB(i,2) decreased. X* For example, set NAB(i,1)=NAB(i,2)-1 to get the largest X* eigenvalue. DLAEBZ is then called with IJOB=2 and MMAX X* no smaller than the value of MOUT returned by the call with X* IJOB=1. After this (IJOB=2) call, eigenvalues NAB(i,1)+1 X* through NAB(i,2) are approximately AB(i,1) (or AB(i,2)) to the X* tolerance specified by ABSTOL and RELTOL. X* X* (b) finding an interval (a',b'] containing eigenvalues w(f),...,w(l). X* In this case, start with a Gershgorin interval (a,b). Set up X* AB to contain 2 search intervals, both initially (a,b). One X* NVAL element should contain f-1 and the other should contain l X* , while C should contain a and b, resp. NAB(i,1) should be -1 X* and NAB(i,2) should be N+1, to flag an error if the desired X* interval does not lie in (a,b). DLAEBZ is then called with X* IJOB=3. On exit, if w(f-1) < w(f), then one of the intervals -- X* j -- will have AB(j,1)=AB(j,2) and NAB(j,1)=NAB(j,2)=f-1, while X* if, to the specified tolerance, w(f-k)=...=w(f+r), k > 0 and r X* >= 0, then the interval will have N(AB(j,1))=NAB(j,1)=f-k and X* N(AB(j,2))=NAB(j,2)=f+r. The cases w(l) < w(l+1) and X* w(l-r)=...=w(l+k) are handled similarly. X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ZERO, TWO, HALF X PARAMETER ( ZERO = 0.0D0, TWO = 2.0D0, X $ HALF = 1.0D0 / TWO ) X* .. X* .. Local Scalars .. X INTEGER ITMP1, ITMP2, J, JI, JIT, JP, KF, KFNEW, KL, X $ KLNEW X DOUBLE PRECISION TMP1, TMP2 X* .. X* .. Intrinsic Functions .. X INTRINSIC ABS, MAX, MIN X* .. X* .. Executable Statements .. X* X* Check for Errors X* X INFO = 0 X IF( IJOB.LT.1 .OR. IJOB.GT.3 ) THEN X INFO = -1 X RETURN X END IF X* X* Initialize NAB X* X IF( IJOB.EQ.1 ) THEN X* X* Compute the number of eigenvalues in the initial intervals. X* X MOUT = 0 X DO 30 JI = 1, MINP X DO 20 JP = 1, 2 X TMP1 = D( 1 ) - AB( JI, JP ) X IF( ABS( TMP1 ).LT.PIVMIN ) X $ TMP1 = -PIVMIN X NAB( JI, JP ) = 0 X IF( TMP1.LE.ZERO ) X $ NAB( JI, JP ) = 1 X* X DO 10 J = 2, N X TMP1 = D( J ) - E2( J-1 ) / TMP1 - AB( JI, JP ) X IF( ABS( TMP1 ).LT.PIVMIN ) X $ TMP1 = -PIVMIN X IF( TMP1.LE.ZERO ) X $ NAB( JI, JP ) = NAB( JI, JP ) + 1 X 10 CONTINUE X 20 CONTINUE X MOUT = MOUT + NAB( JI, 2 ) - NAB( JI, 1 ) X 30 CONTINUE X RETURN X END IF X* X* Initialize for loop X* X* KF and KL have the following meaning: X* Intervals 1,...,KF-1 have converged. X* Intervals KF,...,KL still need to be refined. X* X KF = 1 X KL = MINP X* X* If IJOB=2, initialize C. X* If IJOB=3, use the user-supplied starting point. X* X IF( IJOB.EQ.2 ) THEN X DO 40 JI = 1, MINP X C( JI ) = HALF*( AB( JI, 1 )+AB( JI, 2 ) ) X 40 CONTINUE X END IF X* X* Iteration loop X* X DO 130 JIT = 1, NITMAX X* X* Loop over intervals X* X IF( KL-KF+1.GE.NBMIN .AND. NBMIN.GT.0 ) THEN X* X* Begin of Parallel Version of the loop X* X DO 60 JI = KF, KL X* X* Compute N(c), the number of eigenvalues less than c X* X WORK( JI ) = D( 1 ) - C( JI ) X IWORK( JI ) = 0 X IF( WORK( JI ).LE.PIVMIN ) THEN X IWORK( JI ) = 1 X WORK( JI ) = MIN( WORK( JI ), -PIVMIN ) X END IF X* X DO 50 J = 2, N X WORK( JI ) = D( J ) - E2( J-1 ) / WORK( JI ) - C( JI ) X IF( WORK( JI ).LE.PIVMIN ) THEN X IWORK( JI ) = IWORK( JI ) + 1 X WORK( JI ) = MIN( WORK( JI ), -PIVMIN ) X END IF X 50 CONTINUE X 60 CONTINUE X* X IF( IJOB.LE.2 ) THEN X* X* IJOB=2: Choose all intervals containing eigenvalues. X* X KLNEW = KL X DO 70 JI = KF, KL X* X* Insure that N(w) is monotone X* X IWORK( JI ) = MIN( NAB( JI, 2 ), X $ MAX( NAB( JI, 1 ), IWORK( JI ) ) ) X* X* Update the Queue -- add intervals if both halves X* contain eigenvalues. X* X IF( IWORK( JI ).EQ.NAB( JI, 2 ) ) THEN X* X* No eigenvalue in the upper interval: X* just use the lower interval. X* X AB( JI, 2 ) = C( JI ) X* X ELSE IF( IWORK( JI ).EQ.NAB( JI, 1 ) ) THEN X* X* No eigenvalue in the lower interval: X* just use the upper interval. X* X AB( JI, 1 ) = C( JI ) X ELSE X KLNEW = KLNEW + 1 X IF( KLNEW.LE.MMAX ) THEN X* X* Eigenvalue in both intervals -- add upper to X* queue. X* X AB( KLNEW, 2 ) = AB( JI, 2 ) X NAB( KLNEW, 2 ) = NAB( JI, 2 ) X AB( KLNEW, 1 ) = C( JI ) X NAB( KLNEW, 1 ) = IWORK( JI ) X AB( JI, 2 ) = C( JI ) X NAB( JI, 2 ) = IWORK( JI ) X ELSE X INFO = MMAX + 1 X END IF X END IF X 70 CONTINUE X IF( INFO.NE.0 ) X $ RETURN X KL = KLNEW X ELSE X* X* IJOB=3: Binary search. Keep only the interval containing X* w s.t. N(w) = NVAL X* X DO 80 JI = KF, KL X IF( IWORK( JI ).LE.NVAL( JI ) ) THEN X AB( JI, 1 ) = C( JI ) X NAB( JI, 1 ) = IWORK( JI ) X END IF X IF( IWORK( JI ).GE.NVAL( JI ) ) THEN X AB( JI, 2 ) = C( JI ) X NAB( JI, 2 ) = IWORK( JI ) X END IF X 80 CONTINUE X END IF X* X ELSE X* X* End of Parallel Version of the loop X* X* Begin of Serial Version of the loop X* X KLNEW = KL X DO 100 JI = KF, KL X* X* Compute N(w), the number of eigenvalues less than w X* X TMP1 = C( JI ) X TMP2 = D( 1 ) - TMP1 X ITMP1 = 0 X IF( TMP2.LE.PIVMIN ) THEN X ITMP1 = 1 X TMP2 = MIN( TMP2, -PIVMIN ) X END IF X* X* A series of compiler directives to defeat vectorization X* for the next loop X* X*$PL$ CMCHAR=' ' XCDIR$ NEXTSCALAR XC$DIR SCALAR XCDIR$ NEXT SCALAR XCVD$L NOVECTOR XCDEC$ NOVECTOR XCVD$ NOVECTOR X*VDIR NOVECTOR X*VOCL LOOP,SCALAR XCIBM PREFER SCALAR X*$PL$ CMCHAR='*' X* X DO 90 J = 2, N X TMP2 = D( J ) - E2( J-1 ) / TMP2 - TMP1 X IF( TMP2.LE.PIVMIN ) THEN X ITMP1 = ITMP1 + 1 X TMP2 = MIN( TMP2, -PIVMIN ) X END IF X 90 CONTINUE X* X IF( IJOB.LE.2 ) THEN X* X* IJOB=2: Choose all intervals containing eigenvalues. X* X* Insure that N(w) is monotone X* X ITMP1 = MIN( NAB( JI, 2 ), X $ MAX( NAB( JI, 1 ), ITMP1 ) ) X* X* Update the Queue -- add intervals if both halves X* contain eigenvalues. X* X IF( ITMP1.EQ.NAB( JI, 2 ) ) THEN X* X* No eigenvalue in the upper interval: X* just use the lower interval. X* X AB( JI, 2 ) = TMP1 X* X ELSE IF( ITMP1.EQ.NAB( JI, 1 ) ) THEN X* X* No eigenvalue in the lower interval: X* just use the upper interval. X* X AB( JI, 1 ) = TMP1 X ELSE IF( KLNEW.LT.MMAX ) THEN X* X* Eigenvalue in both intervals -- add upper to queue. X* X KLNEW = KLNEW + 1 X AB( KLNEW, 2 ) = AB( JI, 2 ) X NAB( KLNEW, 2 ) = NAB( JI, 2 ) X AB( KLNEW, 1 ) = TMP1 X NAB( KLNEW, 1 ) = ITMP1 X AB( JI, 2 ) = TMP1 X NAB( JI, 2 ) = ITMP1 X ELSE X INFO = MMAX + 1 X RETURN X END IF X ELSE X* X* IJOB=3: Binary search. Keep only the interval X* containing w s.t. N(w) = NVAL X* X IF( ITMP1.LE.NVAL( JI ) ) THEN X AB( JI, 1 ) = TMP1 X NAB( JI, 1 ) = ITMP1 X END IF X IF( ITMP1.GE.NVAL( JI ) ) THEN X AB( JI, 2 ) = TMP1 X NAB( JI, 2 ) = ITMP1 X END IF X END IF X 100 CONTINUE X KL = KLNEW X* X* End of Serial Version of the loop X* X END IF X* X* Check for convergence X* X KFNEW = KF X DO 110 JI = KF, KL X TMP1 = ABS( AB( JI, 2 )-AB( JI, 1 ) ) X TMP2 = MAX( ABS( AB( JI, 2 ) ), ABS( AB( JI, 1 ) ) ) X IF( TMP1.LT.MAX( ABSTOL, PIVMIN, RELTOL*TMP2 ) .OR. X $ NAB( JI, 1 ).GE.NAB( JI, 2 ) ) THEN X* X* Converged -- Swap with position KFNEW, X* then increment KFNEW X* X IF( JI.GT.KFNEW ) THEN X TMP1 = AB( JI, 1 ) X TMP2 = AB( JI, 2 ) X ITMP1 = NAB( JI, 1 ) X ITMP2 = NAB( JI, 2 ) X AB( JI, 1 ) = AB( KFNEW, 1 ) X AB( JI, 2 ) = AB( KFNEW, 2 ) X NAB( JI, 1 ) = NAB( KFNEW, 1 ) X NAB( JI, 2 ) = NAB( KFNEW, 2 ) X AB( KFNEW, 1 ) = TMP1 X AB( KFNEW, 2 ) = TMP2 X NAB( KFNEW, 1 ) = ITMP1 X NAB( KFNEW, 2 ) = ITMP2 X IF( IJOB.EQ.3 ) THEN X ITMP1 = NVAL( JI ) X NVAL( JI ) = NVAL( KFNEW ) X NVAL( KFNEW ) = ITMP1 X END IF X END IF X KFNEW = KFNEW + 1 X END IF X 110 CONTINUE X KF = KFNEW X* X* Choose Midpoints X* X DO 120 JI = KF, KL X C( JI ) = HALF*( AB( JI, 1 )+AB( JI, 2 ) ) X 120 CONTINUE X* X* If no more intervals to refine, quit. X* X IF( KF.GT.KL ) X $ GO TO 140 X 130 CONTINUE X* X* Converged X* X 140 CONTINUE X INFO = MAX( KL+1-KF, 0 ) X MOUT = KL X* X RETURN X* X* End of DLAEBZ X* X END X SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ ) X* X* -- LAPACK auxiliary routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* October 31, 1992 X* X* .. Scalar Arguments .. X INTEGER INCX, N X DOUBLE PRECISION SCALE, SUMSQ X* .. X* .. Array Arguments .. X DOUBLE PRECISION X( * ) X* .. X* X* Purpose X* ======= X* X* DLASSQ returns the values scl and smsq such that X* X* ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, X* X* where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is X* assumed to be non-negative and scl returns the value X* X* scl = max( scale, abs( x( i ) ) ). X* X* scale and sumsq must be supplied in SCALE and SUMSQ and X* scl and smsq are overwritten on SCALE and SUMSQ respectively. X* X* The routine makes only one pass through the vector x. X* X* Arguments X* ========= X* X* N (input) INTEGER X* The number of elements to be used from the vector X. X* X* X (input) DOUBLE PRECISION X* The vector for which a scaled sum of squares is computed. X* x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. X* X* INCX (input) INTEGER X* The increment between successive values of the vector X. X* INCX > 0. X* X* SCALE (input/output) DOUBLE PRECISION X* On entry, the value scale in the equation above. X* On exit, SCALE is overwritten with scl , the scaling factor X* for the sum of squares. X* X* SUMSQ (input/output) DOUBLE PRECISION X* On entry, the value sumsq in the equation above. X* On exit, SUMSQ is overwritten with smsq , the basic sum of X* squares from which scl has been factored out. X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ZERO X PARAMETER ( ZERO = 0.0D+0 ) X* .. X* .. Local Scalars .. X INTEGER IX X DOUBLE PRECISION ABSXI X* .. X* .. Intrinsic Functions .. X INTRINSIC ABS X* .. X* .. Executable Statements .. X* X IF( N.GT.0 ) THEN X DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX X IF( X( IX ).NE.ZERO ) THEN X ABSXI = ABS( X( IX ) ) X IF( SCALE.LT.ABSXI ) THEN X SUMSQ = 1 + SUMSQ*( SCALE / ABSXI )**2 X SCALE = ABSXI X ELSE X SUMSQ = SUMSQ + ( ABSXI / SCALE )**2 X END IF X END IF X 10 CONTINUE X END IF X RETURN X* X* End of DLASSQ X* X END X SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) X* X* -- LAPACK auxiliary routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* February 29, 1992 X* X* .. Scalar Arguments .. X CHARACTER TYPE X INTEGER INFO, KL, KU, LDA, M, N X DOUBLE PRECISION CFROM, CTO X* .. X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ) X* .. X* X* Purpose X* ======= X* X* DLASCL multiplies the M by N real matrix A by the real scalar X* CTO/CFROM. This is done without over/underflow as long as the final X* result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that X* A may be full, upper triangular, lower triangular, upper Hessenberg, X* or banded. X* X* Arguments X* ========= X* X* TYPE (input) CHARACTER*1 X* TYPE indices the storage type of the input matrix. X* = 'G': A is a full matrix. X* = 'L': A is a lower triangular matrix. X* = 'U': A is an upper triangular matrix. X* = 'H': A is an upper Hessenberg matrix. X* = 'B': A is a symmetric band matrix with lower bandwidth KL X* and upper bandwidth KU and with the only the lower X* half stored. X* = 'Q': A is a symmetric band matrix with lower bandwidth KL X* and upper bandwidth KU and with the only the upper X* half stored. X* = 'Z': A is a band matrix with lower bandwidth KL and upper X* bandwidth KU. X* X* KL (input) INTEGER X* The lower bandwidth of A. Referenced only if TYPE = 'B', X* 'Q' or 'Z'. X* X* KU (input) INTEGER X* The upper bandwidth of A. Referenced only if TYPE = 'B', X* 'Q' or 'Z'. X* X* CFROM (input) DOUBLE PRECISION X* CTO (input) DOUBLE PRECISION X* The matrix A is multiplied by CTO/CFROM. A(I,J) is computed X* without over/underflow if the final result CTO*A(I,J)/CFROM X* can be represented without over/underflow. CFROM must be X* nonzero. X* X* M (input) INTEGER X* The number of rows of the matrix A. M >= 0. X* X* N (input) INTEGER X* The number of columns of the matrix A. N >= 0. X* X* A (input/output) DOUBLE PRECISION array, dimension (LDA,M) X* The matrix to be multiplied by CTO/CFROM. See TYPE for the X* storage type. X* X* LDA (input) INTEGER X* The leading dimension of the array A. LDA >= max(1,M). X* X* INFO (output) INTEGER X* 0 - successful exit X* <0 - if INFO = -i, the i-th argument had an illegal value. X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ZERO, ONE X PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) X* .. X* .. Local Scalars .. X LOGICAL DONE X INTEGER I, ITYPE, J, K1, K2, K3, K4 X DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM X* .. X* .. External Functions .. X LOGICAL LSAME X DOUBLE PRECISION DLAMCH X EXTERNAL LSAME, DLAMCH X* .. X* .. Intrinsic Functions .. X INTRINSIC ABS, MAX, MIN X* .. X* .. External Subroutines .. X EXTERNAL XERBLA X* .. X* .. Executable Statements .. X* X* Test the input arguments X* X INFO = 0 X* X IF( LSAME( TYPE, 'G' ) ) THEN X ITYPE = 0 X ELSE IF( LSAME( TYPE, 'L' ) ) THEN X ITYPE = 1 X ELSE IF( LSAME( TYPE, 'U' ) ) THEN X ITYPE = 2 X ELSE IF( LSAME( TYPE, 'H' ) ) THEN X ITYPE = 3 X ELSE IF( LSAME( TYPE, 'B' ) ) THEN X ITYPE = 4 X ELSE IF( LSAME( TYPE, 'Q' ) ) THEN X ITYPE = 5 X ELSE IF( LSAME( TYPE, 'Z' ) ) THEN X ITYPE = 6 X ELSE X ITYPE = -1 X END IF X* X IF( ITYPE.EQ.-1 ) THEN X INFO = -1 X ELSE IF( CFROM.EQ.ZERO ) THEN X INFO = -4 X ELSE IF( M.LT.0 ) THEN X INFO = -6 X ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR. X $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN X INFO = -7 X ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN X INFO = -9 X ELSE IF( ITYPE.GE.4 ) THEN X IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN X INFO = -2 X ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR. X $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) ) X $ THEN X INFO = -3 X ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR. X $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR. X $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN X INFO = -9 X END IF X END IF X* X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DLASCL', -INFO ) X RETURN X END IF X* X* Quick return if possible X* X IF( N.EQ.0 .OR. M.EQ.0 ) X $ RETURN X* X* Get machine parameters X* X SMLNUM = DLAMCH( 'S' ) X BIGNUM = ONE / SMLNUM X* X CFROMC = CFROM X CTOC = CTO X* X 10 CONTINUE X CFROM1 = CFROMC*SMLNUM X CTO1 = CTOC / BIGNUM X IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN X MUL = SMLNUM X DONE = .FALSE. X CFROMC = CFROM1 X ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN X MUL = BIGNUM X DONE = .FALSE. X CTOC = CTO1 X ELSE X MUL = CTOC / CFROMC X DONE = .TRUE. X END IF X* X IF( ITYPE.EQ.0 ) THEN X* X* Full matrix X* X DO 30 J = 1, N X DO 20 I = 1, M X A( I, J ) = A( I, J )*MUL X 20 CONTINUE X 30 CONTINUE X* X ELSE IF( ITYPE.EQ.1 ) THEN X* X* Lower triangular matrix X* X DO 50 J = 1, N X DO 40 I = J, M X A( I, J ) = A( I, J )*MUL X 40 CONTINUE X 50 CONTINUE X* X ELSE IF( ITYPE.EQ.2 ) THEN X* X* Upper triangular matrix X* X DO 70 J = 1, N X DO 60 I = 1, MIN( J, M ) X A( I, J ) = A( I, J )*MUL X 60 CONTINUE X 70 CONTINUE X* X ELSE IF( ITYPE.EQ.3 ) THEN X* X* Upper Hessenberg matrix X* X DO 90 J = 1, N X DO 80 I = 1, MIN( J+1, M ) X A( I, J ) = A( I, J )*MUL X 80 CONTINUE X 90 CONTINUE X* X ELSE IF( ITYPE.EQ.4 ) THEN X* X* Lower half of a symmetric band matrix X* X K3 = KL + 1 X K4 = N + 1 X DO 110 J = 1, N X DO 100 I = 1, MIN( K3, K4-J ) X A( I, J ) = A( I, J )*MUL X 100 CONTINUE X 110 CONTINUE X* X ELSE IF( ITYPE.EQ.5 ) THEN X* X* Upper half of a symmetric band matrix X* X K1 = KU + 2 X K3 = KU + 1 X DO 130 J = 1, N X DO 120 I = MAX( K1-J, 1 ), K3 X A( I, J ) = A( I, J )*MUL X 120 CONTINUE X 130 CONTINUE X* X ELSE IF( ITYPE.EQ.6 ) THEN X* X* Band matrix X* X K1 = KL + KU + 2 X K2 = KL + 1 X K3 = 2*KL + KU + 1 X K4 = KL + KU + 1 + M X DO 150 J = 1, N X DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J ) X A( I, J ) = A( I, J )*MUL X 140 CONTINUE X 150 CONTINUE X* X END IF X* X IF( .NOT.DONE ) X $ GO TO 10 X* X RETURN X* X* End of DLASCL X* X END X SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) X* X* -- LAPACK auxiliary routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* October 31, 1992 X* X* .. Scalar Arguments .. X INTEGER INCX, K1, K2, LDA, N X* .. X* .. Array Arguments .. X INTEGER IPIV( * ) X DOUBLE PRECISION A( LDA, * ) X* .. X* X* Purpose X* ======= X* X* DLASWP performs a series of row interchanges on the matrix A. X* One row interchange is initiated for each of rows K1 through K2 of A. X* X* Arguments X* ========= X* X* N (input) INTEGER X* The number of columns of the matrix A. X* X* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) X* On entry, the matrix of column dimension N to which the row X* interchanges will be applied. X* On exit, the permuted matrix. X* X* LDA (input) INTEGER X* The leading dimension of the array A. X* X* K1 (input) INTEGER X* The first element of IPIV for which a row interchange will X* be done. X* X* K2 (input) INTEGER X* The last element of IPIV for which a row interchange will X* be done. X* X* IPIV (input) INTEGER array, dimension (M*abs(INCX)) X* The vector of pivot indices. Only the elements in positions X* K1 through K2 of IPIV are accessed. X* IPIV(K) = L implies rows K and L are to be interchanged. X* X* INCX (input) INTEGER X* The increment between successive values of IPIV. If IPIV X* is negative, the pivots are applied in reverse order. X* X* ===================================================================== X* X* .. Local Scalars .. X INTEGER I, IP, IX X* .. X* .. External Subroutines .. X EXTERNAL DSWAP X* .. X* .. Executable Statements .. X* X* Interchange row I with row IPIV(I) for each of rows K1 through K2. X* X IF( INCX.EQ.0 ) X $ RETURN X IF( INCX.GT.0 ) THEN X IX = K1 X ELSE X IX = 1 + ( 1-K2 )*INCX X END IF X IF( INCX.EQ.1 ) THEN X DO 10 I = K1, K2 X IP = IPIV( I ) X IF( IP.NE.I ) X $ CALL DSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA ) X 10 CONTINUE X ELSE IF( INCX.GT.1 ) THEN X DO 20 I = K1, K2 X IP = IPIV( IX ) X IF( IP.NE.I ) X $ CALL DSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA ) X IX = IX + INCX X 20 CONTINUE X ELSE IF( INCX.LT.0 ) THEN X DO 30 I = K2, K1, -1 X IP = IPIV( IX ) X IF( IP.NE.I ) X $ CALL DSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA ) X IX = IX + INCX X 30 CONTINUE X END IF X* X RETURN X* X* End of DLASWP X* X END X SUBROUTINE DORMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, X $ WORK, LWORK, INFO ) X* X* -- LAPACK routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* September 30, 1994 X* X* .. Scalar Arguments .. X CHARACTER SIDE, TRANS X INTEGER INFO, K, LDA, LDC, LWORK, M, N X* .. X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), X $ WORK( LWORK ) X* .. X* X* Purpose X* ======= X* X* DORMQL overwrites the general real M-by-N matrix C with X* X* SIDE = 'L' SIDE = 'R' X* TRANS = 'N': Q * C C * Q X* TRANS = 'T': Q**T * C C * Q**T X* X* where Q is a real orthogonal matrix defined as the product of k X* elementary reflectors X* X* Q = H(k) . . . H(2) H(1) X* X* as returned by DGEQLF. Q is of order M if SIDE = 'L' and of order N X* if SIDE = 'R'. X* X* Arguments X* ========= X* X* SIDE (input) CHARACTER*1 X* = 'L': apply Q or Q**T from the Left; X* = 'R': apply Q or Q**T from the Right. X* X* TRANS (input) CHARACTER*1 X* = 'N': No transpose, apply Q; X* = 'T': Transpose, apply Q**T. X* X* M (input) INTEGER X* The number of rows of the matrix C. M >= 0. X* X* N (input) INTEGER X* The number of columns of the matrix C. N >= 0. X* X* K (input) INTEGER X* The number of elementary reflectors whose product defines X* the matrix Q. X* If SIDE = 'L', M >= K >= 0; X* if SIDE = 'R', N >= K >= 0. X* X* A (input) DOUBLE PRECISION array, dimension (LDA,K) X* The i-th column must contain the vector which defines the X* elementary reflector H(i), for i = 1,2,...,k, as returned by X* DGEQLF in the last k columns of its array argument A. X* A is modified by the routine but restored on exit. X* X* LDA (input) INTEGER X* The leading dimension of the array A. X* If SIDE = 'L', LDA >= max(1,M); X* if SIDE = 'R', LDA >= max(1,N). X* X* TAU (input) DOUBLE PRECISION array, dimension (K) X* TAU(i) must contain the scalar factor of the elementary X* reflector H(i), as returned by DGEQLF. X* X* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) X* On entry, the M-by-N matrix C. X* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. X* X* LDC (input) INTEGER X* The leading dimension of the array C. LDC >= max(1,M). X* X* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) X* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. X* X* LWORK (input) INTEGER X* The dimension of the array WORK. X* If SIDE = 'L', LWORK >= max(1,N); X* if SIDE = 'R', LWORK >= max(1,M). X* For optimum performance LWORK >= N*NB if SIDE = 'L', and X* LWORK >= M*NB if SIDE = 'R', where NB is the optimal X* blocksize. X* X* INFO (output) INTEGER X* = 0: successful exit X* < 0: if INFO = -i, the i-th argument had an illegal value X* X* ===================================================================== X* X* .. Parameters .. X INTEGER NBMAX, LDT X PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) X* .. X* .. Local Scalars .. X LOGICAL LEFT, NOTRAN X INTEGER I, I1, I2, I3, IB, IINFO, IWS, LDWORK, MI, NB, X $ NBMIN, NI, NQ, NW X* .. X* .. Local Arrays .. X DOUBLE PRECISION T( LDT, NBMAX ) X* .. X* .. External Functions .. X LOGICAL LSAME X INTEGER ILAENV X EXTERNAL LSAME, ILAENV X* .. X* .. External Subroutines .. X EXTERNAL DLARFB, DLARFT, DORM2L, XERBLA X* .. X* .. Intrinsic Functions .. X INTRINSIC MAX, MIN X* .. X* .. Executable Statements .. X* X* Test the input arguments X* X INFO = 0 X LEFT = LSAME( SIDE, 'L' ) X NOTRAN = LSAME( TRANS, 'N' ) X* X* NQ is the order of Q and NW is the minimum dimension of WORK X* X IF( LEFT ) THEN X NQ = M X NW = N X ELSE X NQ = N X NW = M X END IF X IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN X INFO = -1 X ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN X INFO = -2 X ELSE IF( M.LT.0 ) THEN X INFO = -3 X ELSE IF( N.LT.0 ) THEN X INFO = -4 X ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN X INFO = -5 X ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN X INFO = -7 X ELSE IF( LDC.LT.MAX( 1, M ) ) THEN X INFO = -10 X ELSE IF( LWORK.LT.MAX( 1, NW ) ) THEN X INFO = -12 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DORMQL', -INFO ) X RETURN X END IF X* X* Quick return if possible X* X IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN X WORK( 1 ) = 1 X RETURN X END IF X* X* Determine the block size. NB may be at most NBMAX, where NBMAX X* is used to define the local array T. X* X NB = MIN( NBMAX, ILAENV( 1, 'DORMQL', SIDE // TRANS, M, N, K, X $ -1 ) ) X NBMIN = 2 X LDWORK = NW X IF( NB.GT.1 .AND. NB.LT.K ) THEN X IWS = NW*NB X IF( LWORK.LT.IWS ) THEN X NB = LWORK / LDWORK X NBMIN = MAX( 2, ILAENV( 2, 'DORMQL', SIDE // TRANS, M, N, K, X $ -1 ) ) X END IF X ELSE X IWS = NW X END IF X* X IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN X* X* Use unblocked code X* X CALL DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, X $ IINFO ) X ELSE X* X* Use blocked code X* X IF( ( LEFT .AND. NOTRAN ) .OR. X $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN X I1 = 1 X I2 = K X I3 = NB X ELSE X I1 = ( ( K-1 ) / NB )*NB + 1 X I2 = 1 X I3 = -NB X END IF X* X IF( LEFT ) THEN X NI = N X ELSE X MI = M X END IF X* X DO 10 I = I1, I2, I3 X IB = MIN( NB, K-I+1 ) X* X* Form the triangular factor of the block reflector X* H = H(i+ib-1) . . . H(i+1) H(i) X* X CALL DLARFT( 'Backward', 'Columnwise', NQ-K+I+IB-1, IB, X $ A( 1, I ), LDA, TAU( I ), T, LDT ) X IF( LEFT ) THEN X* X* H or H' is applied to C(1:m-k+i+ib-1,1:n) X* X MI = M - K + I + IB - 1 X ELSE X* X* H or H' is applied to C(1:m,1:n-k+i+ib-1) X* X NI = N - K + I + IB - 1 X END IF X* X* Apply H or H' X* X CALL DLARFB( SIDE, TRANS, 'Backward', 'Columnwise', MI, NI, X $ IB, A( 1, I ), LDA, T, LDT, C, LDC, WORK, X $ LDWORK ) X 10 CONTINUE X END IF X WORK( 1 ) = IWS X RETURN X* X* End of DORMQL X* X END X SUBROUTINE DLARTG( F, G, CS, SN, R ) X* X* -- LAPACK auxiliary routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* September 30, 1994 X* X* .. Scalar Arguments .. X DOUBLE PRECISION CS, F, G, R, SN X* .. X* X* Purpose X* ======= X* X* DLARTG generate a plane rotation so that X* X* [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1. X* [ -SN CS ] [ G ] [ 0 ] X* X* This is a slower, more accurate version of the BLAS1 routine DROTG, X* with the following other differences: X* F and G are unchanged on return. X* If G=0, then CS=1 and SN=0. X* If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any X* floating point operations (saves work in DBDSQR when X* there are zeros on the diagonal). X* X* If F exceeds G in magnitude, CS will be positive. X* X* Arguments X* ========= X* X* F (input) DOUBLE PRECISION X* The first component of vector to be rotated. X* X* G (input) DOUBLE PRECISION X* The second component of vector to be rotated. X* X* CS (output) DOUBLE PRECISION X* The cosine of the rotation. X* X* SN (output) DOUBLE PRECISION X* The sine of the rotation. X* X* R (output) DOUBLE PRECISION X* The nonzero component of the rotated vector. X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ZERO X PARAMETER ( ZERO = 0.0D0 ) X DOUBLE PRECISION ONE X PARAMETER ( ONE = 1.0D0 ) X DOUBLE PRECISION TWO X PARAMETER ( TWO = 2.0D0 ) X* .. X* .. Local Scalars .. X LOGICAL FIRST X INTEGER COUNT, I X DOUBLE PRECISION EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE X* .. X* .. External Functions .. X DOUBLE PRECISION DLAMCH X EXTERNAL DLAMCH X* .. X* .. Intrinsic Functions .. X INTRINSIC ABS, INT, LOG, MAX, SQRT X* .. X* .. Save statement .. X SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 X* .. X* .. Data statements .. X DATA FIRST / .TRUE. / X* .. X* .. Executable Statements .. X* X IF( FIRST ) THEN X FIRST = .FALSE. X SAFMIN = DLAMCH( 'S' ) X EPS = DLAMCH( 'E' ) X SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / X $ LOG( DLAMCH( 'B' ) ) / TWO ) X SAFMX2 = ONE / SAFMN2 X END IF X IF( G.EQ.ZERO ) THEN X CS = ONE X SN = ZERO X R = F X ELSE IF( F.EQ.ZERO ) THEN X CS = ZERO X SN = ONE X R = G X ELSE X F1 = F X G1 = G X SCALE = MAX( ABS( F1 ), ABS( G1 ) ) X IF( SCALE.GE.SAFMX2 ) THEN X COUNT = 0 X 10 CONTINUE X COUNT = COUNT + 1 X F1 = F1*SAFMN2 X G1 = G1*SAFMN2 X SCALE = MAX( ABS( F1 ), ABS( G1 ) ) X IF( SCALE.GE.SAFMX2 ) X $ GO TO 10 X R = SQRT( F1**2+G1**2 ) X CS = F1 / R X SN = G1 / R X DO 20 I = 1, COUNT X R = R*SAFMX2 X 20 CONTINUE X ELSE IF( SCALE.LE.SAFMN2 ) THEN X COUNT = 0 X 30 CONTINUE X COUNT = COUNT + 1 X F1 = F1*SAFMX2 X G1 = G1*SAFMX2 X SCALE = MAX( ABS( F1 ), ABS( G1 ) ) X IF( SCALE.LE.SAFMN2 ) X $ GO TO 30 X R = SQRT( F1**2+G1**2 ) X CS = F1 / R X SN = G1 / R X DO 40 I = 1, COUNT X R = R*SAFMN2 X 40 CONTINUE X ELSE X R = SQRT( F1**2+G1**2 ) X CS = F1 / R X SN = G1 / R X END IF X IF( ABS( F ).GT.ABS( G ) .AND. CS.LT.ZERO ) THEN X CS = -CS X SN = -SN X R = -R X END IF X END IF X RETURN X* X* End of DLARTG X* X END X DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) X* X* -- LAPACK auxiliary routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* October 31, 1992 X* X* .. Scalar Arguments .. X DOUBLE PRECISION X, Y X* .. X* X* Purpose X* ======= X* X* DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary X* overflow. X* X* Arguments X* ========= X* X* X (input) DOUBLE PRECISION X* Y (input) DOUBLE PRECISION X* X and Y specify the values x and y. X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ZERO X PARAMETER ( ZERO = 0.0D0 ) X DOUBLE PRECISION ONE X PARAMETER ( ONE = 1.0D0 ) X* .. X* .. Local Scalars .. X DOUBLE PRECISION W, XABS, YABS, Z X* .. X* .. Intrinsic Functions .. X INTRINSIC ABS, MAX, MIN, SQRT X* .. X* .. Executable Statements .. X* X XABS = ABS( X ) X YABS = ABS( Y ) X W = MAX( XABS, YABS ) X Z = MIN( XABS, YABS ) X IF( Z.EQ.ZERO ) THEN X DLAPY2 = W X ELSE X DLAPY2 = W*SQRT( ONE+( Z / W )**2 ) X END IF X RETURN X* X* End of DLAPY2 X* X END X SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) X* X* -- LAPACK auxiliary routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* October 31, 1992 X* X* .. Scalar Arguments .. X CHARACTER DIRECT, PIVOT, SIDE X INTEGER LDA, M, N X* .. X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), C( * ), S( * ) X* .. X* X* Purpose X* ======= X* X* DLASR performs the transformation X* X* A := P*A, when SIDE = 'L' or 'l' ( Left-hand side ) X* X* A := A*P', when SIDE = 'R' or 'r' ( Right-hand side ) X* X* where A is an m by n real matrix and P is an orthogonal matrix, X* consisting of a sequence of plane rotations determined by the X* parameters PIVOT and DIRECT as follows ( z = m when SIDE = 'L' or 'l' X* and z = n when SIDE = 'R' or 'r' ): X* X* When DIRECT = 'F' or 'f' ( Forward sequence ) then X* X* P = P( z - 1 )*...*P( 2 )*P( 1 ), X* X* and when DIRECT = 'B' or 'b' ( Backward sequence ) then X* X* P = P( 1 )*P( 2 )*...*P( z - 1 ), X* X* where P( k ) is a plane rotation matrix for the following planes: X* X* when PIVOT = 'V' or 'v' ( Variable pivot ), X* the plane ( k, k + 1 ) X* X* when PIVOT = 'T' or 't' ( Top pivot ), X* the plane ( 1, k + 1 ) X* X* when PIVOT = 'B' or 'b' ( Bottom pivot ), X* the plane ( k, z ) X* X* c( k ) and s( k ) must contain the cosine and sine that define the X* matrix P( k ). The two by two plane rotation part of the matrix X* P( k ), R( k ), is assumed to be of the form X* X* R( k ) = ( c( k ) s( k ) ). X* ( -s( k ) c( k ) ) X* X* This version vectorises across rows of the array A when SIDE = 'L'. X* X* Arguments X* ========= X* X* SIDE (input) CHARACTER*1 X* Specifies whether the plane rotation matrix P is applied to X* A on the left or the right. X* = 'L': Left, compute A := P*A X* = 'R': Right, compute A:= A*P' X* X* DIRECT (input) CHARACTER*1 X* Specifies whether P is a forward or backward sequence of X* plane rotations. X* = 'F': Forward, P = P( z - 1 )*...*P( 2 )*P( 1 ) X* = 'B': Backward, P = P( 1 )*P( 2 )*...*P( z - 1 ) X* X* PIVOT (input) CHARACTER*1 X* Specifies the plane for which P(k) is a plane rotation X* matrix. X* = 'V': Variable pivot, the plane (k,k+1) X* = 'T': Top pivot, the plane (1,k+1) X* = 'B': Bottom pivot, the plane (k,z) X* X* M (input) INTEGER X* The number of rows of the matrix A. If m <= 1, an immediate X* return is effected. X* X* N (input) INTEGER X* The number of columns of the matrix A. If n <= 1, an X* immediate return is effected. X* X* C, S (input) DOUBLE PRECISION arrays, dimension X* (M-1) if SIDE = 'L' X* (N-1) if SIDE = 'R' X* c(k) and s(k) contain the cosine and sine that define the X* matrix P(k). The two by two plane rotation part of the X* matrix P(k), R(k), is assumed to be of the form X* R( k ) = ( c( k ) s( k ) ). X* ( -s( k ) c( k ) ) X* X* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) X* The m by n matrix A. On exit, A is overwritten by P*A if X* SIDE = 'R' or by A*P' if SIDE = 'L'. X* X* LDA (input) INTEGER X* The leading dimension of the array A. LDA >= max(1,M). X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ONE, ZERO X PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) X* .. X* .. Local Scalars .. X INTEGER I, INFO, J X DOUBLE PRECISION CTEMP, STEMP, TEMP X* .. X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. X* .. External Subroutines .. X EXTERNAL XERBLA X* .. X* .. Intrinsic Functions .. X INTRINSIC MAX X* .. X* .. Executable Statements .. X* X* Test the input parameters X* X INFO = 0 X IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN X INFO = 1 X ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT, X $ 'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN X INFO = 2 X ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) ) X $ THEN X INFO = 3 X ELSE IF( M.LT.0 ) THEN X INFO = 4 X ELSE IF( N.LT.0 ) THEN X INFO = 5 X ELSE IF( LDA.LT.MAX( 1, M ) ) THEN X INFO = 9 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DLASR ', INFO ) X RETURN X END IF X* X* Quick return if possible X* X IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) ) X $ RETURN X IF( LSAME( SIDE, 'L' ) ) THEN X* X* Form P * A X* X IF( LSAME( PIVOT, 'V' ) ) THEN X IF( LSAME( DIRECT, 'F' ) ) THEN X DO 20 J = 1, M - 1 X CTEMP = C( J ) X STEMP = S( J ) X IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN X DO 10 I = 1, N X TEMP = A( J+1, I ) X A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) X A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) X 10 CONTINUE X END IF X 20 CONTINUE X ELSE IF( LSAME( DIRECT, 'B' ) ) THEN X DO 40 J = M - 1, 1, -1 X CTEMP = C( J ) X STEMP = S( J ) X IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN X DO 30 I = 1, N X TEMP = A( J+1, I ) X A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) X A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) X 30 CONTINUE X END IF X 40 CONTINUE X END IF X ELSE IF( LSAME( PIVOT, 'T' ) ) THEN X IF( LSAME( DIRECT, 'F' ) ) THEN X DO 60 J = 2, M X CTEMP = C( J-1 ) X STEMP = S( J-1 ) X IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN X DO 50 I = 1, N X TEMP = A( J, I ) X A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) X A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) X 50 CONTINUE X END IF X 60 CONTINUE X ELSE IF( LSAME( DIRECT, 'B' ) ) THEN X DO 80 J = M, 2, -1 X CTEMP = C( J-1 ) X STEMP = S( J-1 ) X IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN X DO 70 I = 1, N X TEMP = A( J, I ) X A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) X A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) X 70 CONTINUE X END IF X 80 CONTINUE X END IF X ELSE IF( LSAME( PIVOT, 'B' ) ) THEN X IF( LSAME( DIRECT, 'F' ) ) THEN X DO 100 J = 1, M - 1 X CTEMP = C( J ) X STEMP = S( J ) X IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN X DO 90 I = 1, N X TEMP = A( J, I ) X A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP X A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP X 90 CONTINUE X END IF X 100 CONTINUE X ELSE IF( LSAME( DIRECT, 'B' ) ) THEN X DO 120 J = M - 1, 1, -1 X CTEMP = C( J ) X STEMP = S( J ) X IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN X DO 110 I = 1, N X TEMP = A( J, I ) X A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP X A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP X 110 CONTINUE X END IF X 120 CONTINUE X END IF X END IF X ELSE IF( LSAME( SIDE, 'R' ) ) THEN X* X* Form A * P' X* X IF( LSAME( PIVOT, 'V' ) ) THEN X IF( LSAME( DIRECT, 'F' ) ) THEN X DO 140 J = 1, N - 1 X CTEMP = C( J ) X STEMP = S( J ) X IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN X DO 130 I = 1, M X TEMP = A( I, J+1 ) X A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) X A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) X 130 CONTINUE X END IF X 140 CONTINUE X ELSE IF( LSAME( DIRECT, 'B' ) ) THEN X DO 160 J = N - 1, 1, -1 X CTEMP = C( J ) X STEMP = S( J ) X IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN X DO 150 I = 1, M X TEMP = A( I, J+1 ) X A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) X A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) X 150 CONTINUE X END IF X 160 CONTINUE X END IF X ELSE IF( LSAME( PIVOT, 'T' ) ) THEN X IF( LSAME( DIRECT, 'F' ) ) THEN X DO 180 J = 2, N X CTEMP = C( J-1 ) X STEMP = S( J-1 ) X IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN X DO 170 I = 1, M X TEMP = A( I, J ) X A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) X A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) X 170 CONTINUE X END IF X 180 CONTINUE X ELSE IF( LSAME( DIRECT, 'B' ) ) THEN X DO 200 J = N, 2, -1 X CTEMP = C( J-1 ) X STEMP = S( J-1 ) X IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN X DO 190 I = 1, M X TEMP = A( I, J ) X A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) X A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) X 190 CONTINUE X END IF X 200 CONTINUE X END IF X ELSE IF( LSAME( PIVOT, 'B' ) ) THEN X IF( LSAME( DIRECT, 'F' ) ) THEN X DO 220 J = 1, N - 1 X CTEMP = C( J ) X STEMP = S( J ) X IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN X DO 210 I = 1, M X TEMP = A( I, J ) X A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP X A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP X 210 CONTINUE X END IF X 220 CONTINUE X ELSE IF( LSAME( DIRECT, 'B' ) ) THEN X DO 240 J = N - 1, 1, -1 X CTEMP = C( J ) X STEMP = S( J ) X IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN X DO 230 I = 1, M X TEMP = A( I, J ) X A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP X A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP X 230 CONTINUE X END IF X 240 CONTINUE X END IF X END IF X END IF X* X RETURN X* X* End of DLASR X* X END X SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) X* X* -- LAPACK routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* June 30, 1992 X* X* .. Scalar Arguments .. X INTEGER INFO, LDA, M, N X* .. X* .. Array Arguments .. X INTEGER IPIV( * ) X DOUBLE PRECISION A( LDA, * ) X* .. X* X* Purpose X* ======= X* X* DGETF2 computes an LU factorization of a general m-by-n matrix A X* using partial pivoting with row interchanges. X* X* The factorization has the form X* A = P * L * U X* where P is a permutation matrix, L is lower triangular with unit X* diagonal elements (lower trapezoidal if m > n), and U is upper X* triangular (upper trapezoidal if m < n). X* X* This is the right-looking Level 2 BLAS version of the algorithm. X* X* Arguments X* ========= X* X* M (input) INTEGER X* The number of rows of the matrix A. M >= 0. X* X* N (input) INTEGER X* The number of columns of the matrix A. N >= 0. X* X* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) X* On entry, the m by n matrix to be factored. X* On exit, the factors L and U from the factorization X* A = P*L*U; the unit diagonal elements of L are not stored. X* X* LDA (input) INTEGER X* The leading dimension of the array A. LDA >= max(1,M). X* X* IPIV (output) INTEGER array, dimension (min(M,N)) X* The pivot indices; for 1 <= i <= min(M,N), row i of the X* matrix was interchanged with row IPIV(i). X* X* INFO (output) INTEGER X* = 0: successful exit X* < 0: if INFO = -k, the k-th argument had an illegal value X* > 0: if INFO = k, U(k,k) is exactly zero. The factorization X* has been completed, but the factor U is exactly X* singular, and division by zero will occur if it is used X* to solve a system of equations. X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ONE, ZERO X PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) X* .. X* .. Local Scalars .. X INTEGER J, JP X* .. X* .. External Functions .. X INTEGER IDAMAX X EXTERNAL IDAMAX X* .. X* .. External Subroutines .. X EXTERNAL DGER, DSCAL, DSWAP, XERBLA X* .. X* .. Intrinsic Functions .. X INTRINSIC MAX, MIN X* .. X* .. Executable Statements .. X* X* Test the input parameters. X* X INFO = 0 X IF( M.LT.0 ) THEN X INFO = -1 X ELSE IF( N.LT.0 ) THEN X INFO = -2 X ELSE IF( LDA.LT.MAX( 1, M ) ) THEN X INFO = -4 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DGETF2', -INFO ) X RETURN X END IF X* X* Quick return if possible X* X IF( M.EQ.0 .OR. N.EQ.0 ) X $ RETURN X* X DO 10 J = 1, MIN( M, N ) X* X* Find pivot and test for singularity. X* X JP = J - 1 + IDAMAX( M-J+1, A( J, J ), 1 ) X IPIV( J ) = JP X IF( A( JP, J ).NE.ZERO ) THEN X* X* Apply the interchange to columns 1:N. X* X IF( JP.NE.J ) X $ CALL DSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA ) X* X* Compute elements J+1:M of J-th column. X* X IF( J.LT.M ) X $ CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) X* X ELSE IF( INFO.EQ.0 ) THEN X* X INFO = J X END IF X* X IF( J.LT.MIN( M, N ) ) THEN X* X* Update trailing submatrix. X* X CALL DGER( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), LDA, X $ A( J+1, J+1 ), LDA ) X END IF X 10 CONTINUE X RETURN X* X* End of DGETF2 X* X END X* X SUBROUTINE DLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, INFO ) X* X* -- LAPACK routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* October 31, 1992 X* X* .. Scalar Arguments .. X INTEGER INFO, N X DOUBLE PRECISION LAMBDA, TOL X* .. X* .. Array Arguments .. X INTEGER IN( * ) X DOUBLE PRECISION A( * ), B( * ), C( * ), D( * ) X* .. X* X* Purpose X* ======= X* X* DLAGTF factorizes the matrix (T - lambda*I), where T is an n by n X* tridiagonal matrix and lambda is a scalar, as X* X* T - lambda*I = PLU, X* X* where P is a permutation matrix, L is a unit lower tridiagonal matrix X* with at most one non-zero sub-diagonal elements per column and U is X* an upper triangular matrix with at most two non-zero super-diagonal X* elements per column. X* X* The factorization is obtained by Gaussian elimination with partial X* pivoting and implicit row scaling. X* X* The parameter LAMBDA is included in the routine so that DLAGTF may X* be used, in conjunction with DLAGTS, to obtain eigenvectors of T by X* inverse iteration. X* X* Arguments X* ========= X* X* N (input) INTEGER X* The order of the matrix T. X* X* A (input/output) DOUBLE PRECISION array, dimension (N) X* On entry, A must contain the diagonal elements of T. X* X* On exit, A is overwritten by the n diagonal elements of the X* upper triangular matrix U of the factorization of T. X* X* LAMBDA (input) DOUBLE PRECISION X* On entry, the scalar lambda. X* X* B (input/output) DOUBLE PRECISION array, dimension (N-1) X* On entry, B must contain the (n-1) super-diagonal elements of X* T. X* X* On exit, B is overwritten by the (n-1) super-diagonal X* elements of the matrix U of the factorization of T. X* X* C (input/output) DOUBLE PRECISION array, dimension (N-1) X* On entry, C must contain the (n-1) sub-diagonal elements of X* T. X* X* On exit, C is overwritten by the (n-1) sub-diagonal elements X* of the matrix L of the factorization of T. X* X* TOL (input) DOUBLE PRECISION X* On entry, a relative tolerance used to indicate whether or X* not the matrix (T - lambda*I) is nearly singular. TOL should X* normally be chose as approximately the largest relative error X* in the elements of T. For example, if the elements of T are X* correct to about 4 significant figures, then TOL should be X* set to about 5*10**(-4). If TOL is supplied as less than eps, X* where eps is the relative machine precision, then the value X* eps is used in place of TOL. X* X* D (output) DOUBLE PRECISION array, dimension (N-2) X* On exit, D is overwritten by the (n-2) second super-diagonal X* elements of the matrix U of the factorization of T. X* X* IN (output) INTEGER array, dimension (N) X* On exit, IN contains details of the permutation matrix P. If X* an interchange occurred at the kth step of the elimination, X* then IN(k) = 1, otherwise IN(k) = 0. The element IN(n) X* returns the smallest positive integer j such that X* X* abs( u(j,j) ).le. norm( (T - lambda*I)(j) )*TOL, X* X* where norm( A(j) ) denotes the sum of the absolute values of X* the jth row of the matrix A. If no such j exists then IN(n) X* is returned as zero. If IN(n) is returned as positive, then a X* diagonal element of U is small, indicating that X* (T - lambda*I) is singular or nearly singular, X* X* INFO (output) X* = 0 : successful exit X* .lt. 0: if INFO = -k, the kth argument had an illegal value X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ZERO X PARAMETER ( ZERO = 0.0D+0 ) X* .. X* .. Local Scalars .. X INTEGER K X DOUBLE PRECISION EPS, MULT, PIV1, PIV2, SCALE1, SCALE2, TEMP, TL X* .. X* .. Intrinsic Functions .. X INTRINSIC ABS, MAX X* .. X* .. External Functions .. X DOUBLE PRECISION DLAMCH X EXTERNAL DLAMCH X* .. X* .. External Subroutines .. X EXTERNAL XERBLA X* .. X* .. Executable Statements .. X* X INFO = 0 X IF( N.LT.0 ) THEN X INFO = -1 X CALL XERBLA( 'DLAGTF', -INFO ) X RETURN X END IF X* X IF( N.EQ.0 ) X $ RETURN X* X A( 1 ) = A( 1 ) - LAMBDA X IN( N ) = 0 X IF( N.EQ.1 ) THEN X IF( A( 1 ).EQ.ZERO ) X $ IN( 1 ) = 1 X RETURN X END IF X* X EPS = DLAMCH( 'Epsilon' ) X* X TL = MAX( TOL, EPS ) X SCALE1 = ABS( A( 1 ) ) + ABS( B( 1 ) ) X DO 10 K = 1, N - 1 X A( K+1 ) = A( K+1 ) - LAMBDA X SCALE2 = ABS( C( K ) ) + ABS( A( K+1 ) ) X IF( K.LT.( N-1 ) ) X $ SCALE2 = SCALE2 + ABS( B( K+1 ) ) X IF( A( K ).EQ.ZERO ) THEN X PIV1 = ZERO X ELSE X PIV1 = ABS( A( K ) ) / SCALE1 X END IF X IF( C( K ).EQ.ZERO ) THEN X IN( K ) = 0 X PIV2 = ZERO X SCALE1 = SCALE2 X IF( K.LT.( N-1 ) ) X $ D( K ) = ZERO X ELSE X PIV2 = ABS( C( K ) ) / SCALE2 X IF( PIV2.LE.PIV1 ) THEN X IN( K ) = 0 X SCALE1 = SCALE2 X C( K ) = C( K ) / A( K ) X A( K+1 ) = A( K+1 ) - C( K )*B( K ) X IF( K.LT.( N-1 ) ) X $ D( K ) = ZERO X ELSE X IN( K ) = 1 X MULT = A( K ) / C( K ) X A( K ) = C( K ) X TEMP = A( K+1 ) X A( K+1 ) = B( K ) - MULT*TEMP X IF( K.LT.( N-1 ) ) THEN X D( K ) = B( K+1 ) X B( K+1 ) = -MULT*D( K ) X END IF X B( K ) = TEMP X C( K ) = MULT X END IF X END IF X IF( ( MAX( PIV1, PIV2 ).LE.TL ) .AND. ( IN( N ).EQ.0 ) ) X $ IN( N ) = K X 10 CONTINUE X IF( ( ABS( A( N ) ).LE.SCALE1*TL ) .AND. ( IN( N ).EQ.0 ) ) X $ IN( N ) = N X* X RETURN X* X* End of DLAGTF X* X END X SUBROUTINE DSTERF( N, D, E, INFO ) X* X* -- LAPACK routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* September 30, 1994 X* X* .. Scalar Arguments .. X INTEGER INFO, N X* .. X* .. Array Arguments .. X DOUBLE PRECISION D( * ), E( * ) X* .. X* X* Purpose X* ======= X* X* DSTERF computes all eigenvalues of a symmetric tridiagonal matrix X* using the Pal-Walker-Kahan variant of the QL or QR algorithm. X* X* Arguments X* ========= X* X* N (input) INTEGER X* The order of the matrix. N >= 0. X* X* D (input/output) DOUBLE PRECISION array, dimension (N) X* On entry, the n diagonal elements of the tridiagonal matrix. X* On exit, if INFO = 0, the eigenvalues in ascending order. X* X* E (input/output) DOUBLE PRECISION array, dimension (N-1) X* On entry, the (n-1) subdiagonal elements of the tridiagonal X* matrix. X* On exit, E has been destroyed. X* X* INFO (output) INTEGER X* = 0: successful exit X* < 0: if INFO = -i, the i-th argument had an illegal value X* > 0: the algorithm failed to find all of the eigenvalues in X* a total of 30*N iterations; if INFO = i, then i X* elements of E have not converged to zero. X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ZERO, ONE, TWO, THREE X PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, X $ THREE = 3.0D0 ) X INTEGER MAXIT X PARAMETER ( MAXIT = 30 ) X* .. X* .. Local Scalars .. X INTEGER I, ISCALE, JTOT, L, L1, LEND, LENDM1, LENDP1, X $ LENDSV, LM1, LSV, M, MM1, NM1, NMAXIT X DOUBLE PRECISION ALPHA, ANORM, BB, C, EPS, EPS2, GAMMA, OLDC, X $ OLDGAM, P, R, RT1, RT2, RTE, S, SAFMAX, SAFMIN, X $ SIGMA, SSFMAX, SSFMIN, TST X* .. X* .. External Functions .. X DOUBLE PRECISION DLAMCH, DLANST, DLAPY2 X EXTERNAL DLAMCH, DLANST, DLAPY2 X* .. X* .. External Subroutines .. X EXTERNAL DLAE2, DLASCL, DLASRT, XERBLA X* .. X* .. Intrinsic Functions .. X INTRINSIC ABS, SIGN, SQRT X* .. X* .. Executable Statements .. X* X* Test the input parameters. X* X INFO = 0 X* X* Quick return if possible X* X IF( N.LT.0 ) THEN X INFO = -1 X CALL XERBLA( 'DSTERF', -INFO ) X RETURN X END IF X IF( N.LE.1 ) X $ RETURN X* X* Determine the unit roundoff for this environment. X* X EPS = DLAMCH( 'E' ) X EPS2 = EPS**2 X SAFMIN = DLAMCH( 'S' ) X SAFMAX = ONE / SAFMIN X SSFMAX = SQRT( SAFMAX ) / THREE X SSFMIN = SQRT( SAFMIN ) / EPS2 X* X* Compute the eigenvalues of the tridiagonal matrix. X* X NMAXIT = N*MAXIT X SIGMA = ZERO X JTOT = 0 X* X* Determine where the matrix splits and choose QL or QR iteration X* for each block, according to whether top or bottom diagonal X* element is smaller. X* X L1 = 1 X NM1 = N - 1 X* X 10 CONTINUE X IF( L1.GT.N ) X $ GO TO 170 X IF( L1.GT.1 ) X $ E( L1-1 ) = ZERO X IF( L1.LE.NM1 ) THEN X DO 20 M = L1, NM1 X TST = ABS( E( M ) ) X IF( TST.EQ.ZERO ) X $ GO TO 30 X IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+ X $ 1 ) ) ) )*EPS ) THEN X E( M ) = ZERO X GO TO 30 X END IF X 20 CONTINUE X END IF X M = N X* X 30 CONTINUE X L = L1 X LSV = L X LEND = M X LENDSV = LEND X L1 = M + 1 X IF( LEND.EQ.L ) X $ GO TO 10 X* X* Scale submatrix in rows and columns L to LEND X* X ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) ) X ISCALE = 0 X IF( ANORM.GT.SSFMAX ) THEN X ISCALE = 1 X CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, X $ INFO ) X CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, X $ INFO ) X ELSE IF( ANORM.LT.SSFMIN ) THEN X ISCALE = 2 X CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N, X $ INFO ) X CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, X $ INFO ) X END IF X* X DO 40 I = L, LEND - 1 X E( I ) = E( I )**2 X 40 CONTINUE X* X* Choose between QL and QR iteration X* X IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN X LEND = LSV X L = LENDSV X END IF X* X IF( LEND.GE.L ) THEN X* X* QL Iteration X* X* Look for small subdiagonal element. X* X 50 CONTINUE X IF( L.NE.LEND ) THEN X LENDM1 = LEND - 1 X DO 60 M = L, LENDM1 X TST = ABS( E( M ) ) X IF( TST.LE.EPS2*ABS( D( M )*D( M+1 ) ) ) X $ GO TO 70 X 60 CONTINUE X END IF X* X M = LEND X* X 70 CONTINUE X IF( M.LT.LEND ) X $ E( M ) = ZERO X P = D( L ) X IF( M.EQ.L ) X $ GO TO 90 X* X* If remaining matrix is 2 by 2, use DLAE2 to compute its X* eigenvalues. X* X IF( M.EQ.L+1 ) THEN X RTE = SQRT( E( L ) ) X CALL DLAE2( D( L ), RTE, D( L+1 ), RT1, RT2 ) X D( L ) = RT1 X D( L+1 ) = RT2 X E( L ) = ZERO X L = L + 2 X IF( L.LE.LEND ) X $ GO TO 50 X GO TO 150 X END IF X* X IF( JTOT.EQ.NMAXIT ) X $ GO TO 150 X JTOT = JTOT + 1 X* X* Form shift. X* X RTE = SQRT( E( L ) ) X SIGMA = ( D( L+1 )-P ) / ( TWO*RTE ) X R = DLAPY2( SIGMA, ONE ) X SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) ) X* X C = ONE X S = ZERO X GAMMA = D( M ) - SIGMA X P = GAMMA*GAMMA X* X* Inner loop X* X MM1 = M - 1 X DO 80 I = MM1, L, -1 X BB = E( I ) X R = P + BB X IF( I.NE.M-1 ) X $ E( I+1 ) = S*R X OLDC = C X C = P / R X S = BB / R X OLDGAM = GAMMA X ALPHA = D( I ) X GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM X D( I+1 ) = OLDGAM + ( ALPHA-GAMMA ) X IF( C.NE.ZERO ) THEN X P = ( GAMMA*GAMMA ) / C X ELSE X P = OLDC*BB X END IF X 80 CONTINUE X* X E( L ) = S*P X D( L ) = SIGMA + GAMMA X GO TO 50 X* X* Eigenvalue found. X* X 90 CONTINUE X D( L ) = P X* X L = L + 1 X IF( L.LE.LEND ) X $ GO TO 50 X GO TO 150 X* X ELSE X* X* QR Iteration X* X* Look for small superdiagonal element. X* X 100 CONTINUE X IF( L.NE.LEND ) THEN X LENDP1 = LEND + 1 X DO 110 M = L, LENDP1, -1 X TST = ABS( E( M-1 ) ) X IF( TST.LE.EPS2*ABS( D( M )*D( M-1 ) ) ) X $ GO TO 120 X 110 CONTINUE X END IF X* X M = LEND X* X 120 CONTINUE X IF( M.GT.LEND ) X $ E( M-1 ) = ZERO X P = D( L ) X IF( M.EQ.L ) X $ GO TO 140 X* X* If remaining matrix is 2 by 2, use DLAE2 to compute its X* eigenvalues. X* X IF( M.EQ.L-1 ) THEN X RTE = SQRT( E( L-1 ) ) X CALL DLAE2( D( L ), RTE, D( L-1 ), RT1, RT2 ) X D( L ) = RT1 X D( L-1 ) = RT2 X E( L-1 ) = ZERO X L = L - 2 X IF( L.GE.LEND ) X $ GO TO 100 X GO TO 150 X END IF X* X IF( JTOT.EQ.NMAXIT ) X $ GO TO 150 X JTOT = JTOT + 1 X* X* Form shift. X* X RTE = SQRT( E( L-1 ) ) X SIGMA = ( D( L-1 )-P ) / ( TWO*RTE ) X R = DLAPY2( SIGMA, ONE ) X SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) ) X* X C = ONE X S = ZERO X GAMMA = D( M ) - SIGMA X P = GAMMA*GAMMA X* X* Inner loop X* X LM1 = L - 1 X DO 130 I = M, LM1 X BB = E( I ) X R = P + BB X IF( I.NE.M ) X $ E( I-1 ) = S*R X OLDC = C X C = P / R X S = BB / R X OLDGAM = GAMMA X ALPHA = D( I+1 ) X GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM X D( I ) = OLDGAM + ( ALPHA-GAMMA ) X IF( C.NE.ZERO ) THEN X P = ( GAMMA*GAMMA ) / C X ELSE X P = OLDC*BB X END IF X 130 CONTINUE X* X E( LM1 ) = S*P X D( L ) = SIGMA + GAMMA X GO TO 100 X* X* Eigenvalue found. X* X 140 CONTINUE X D( L ) = P X* X L = L - 1 X IF( L.GE.LEND ) X $ GO TO 100 X GO TO 150 X* X END IF X* X* Undo scaling if necessary X* X 150 CONTINUE X IF( ISCALE.EQ.1 ) X $ CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1, X $ D( LSV ), N, INFO ) X IF( ISCALE.EQ.2 ) X $ CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1, X $ D( LSV ), N, INFO ) X* X* Check for no convergence to an eigenvalue after a total X* of N*MAXIT iterations. X* X IF( JTOT.EQ.NMAXIT ) THEN X DO 160 I = 1, N - 1 X IF( E( I ).NE.ZERO ) X $ INFO = INFO + 1 X 160 CONTINUE X RETURN X END IF X GO TO 10 X* X* Sort eigenvalues in increasing order. X* X 170 CONTINUE X CALL DLASRT( 'I', N, D, INFO ) X* X RETURN X* X* End of DSTERF X* X END X* X SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, X $ T, LDT, C, LDC, WORK, LDWORK ) X* X* -- LAPACK auxiliary routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* February 29, 1992 X* X* .. Scalar Arguments .. X CHARACTER DIRECT, SIDE, STOREV, TRANS X INTEGER K, LDC, LDT, LDV, LDWORK, M, N X* .. X* .. Array Arguments .. X DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ), X $ WORK( LDWORK, * ) X* .. X* X* Purpose X* ======= X* X* DLARFB applies a real block reflector H or its transpose H' to a X* real m by n matrix C, from either the left or the right. X* X* Arguments X* ========= X* X* SIDE (input) CHARACTER*1 X* = 'L': apply H or H' from the Left X* = 'R': apply H or H' from the Right X* X* TRANS (input) CHARACTER*1 X* = 'N': apply H (No transpose) X* = 'T': apply H' (Transpose) X* X* DIRECT (input) CHARACTER*1 X* Indicates how H is formed from a product of elementary X* reflectors X* = 'F': H = H(1) H(2) . . . H(k) (Forward) X* = 'B': H = H(k) . . . H(2) H(1) (Backward) X* X* STOREV (input) CHARACTER*1 X* Indicates how the vectors which define the elementary X* reflectors are stored: X* = 'C': Columnwise X* = 'R': Rowwise X* X* M (input) INTEGER X* The number of rows of the matrix C. X* X* N (input) INTEGER X* The number of columns of the matrix C. X* X* K (input) INTEGER X* The order of the matrix T (= the number of elementary X* reflectors whose product defines the block reflector). X* X* V (input) DOUBLE PRECISION array, dimension X* (LDV,K) if STOREV = 'C' X* (LDV,M) if STOREV = 'R' and SIDE = 'L' X* (LDV,N) if STOREV = 'R' and SIDE = 'R' X* The matrix V. See further details. X* X* LDV (input) INTEGER X* The leading dimension of the array V. X* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); X* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); X* if STOREV = 'R', LDV >= K. X* X* T (input) DOUBLE PRECISION array, dimension (LDT,K) X* The triangular k by k matrix T in the representation of the X* block reflector. X* X* LDT (input) INTEGER X* The leading dimension of the array T. LDT >= K. X* X* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) X* On entry, the m by n matrix C. X* On exit, C is overwritten by H*C or H'*C or C*H or C*H'. X* X* LDC (input) INTEGER X* The leading dimension of the array C. LDA >= max(1,M). X* X* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,K) X* X* LDWORK (input) INTEGER X* The leading dimension of the array WORK. X* If SIDE = 'L', LDWORK >= max(1,N); X* if SIDE = 'R', LDWORK >= max(1,M). X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ONE X PARAMETER ( ONE = 1.0D+0 ) X* .. X* .. Local Scalars .. X CHARACTER TRANST X INTEGER I, J X* .. X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. X* .. External Subroutines .. X EXTERNAL DCOPY, DGEMM, DTRMM X* .. X* .. Executable Statements .. X* X* Quick return if possible X* X IF( M.LE.0 .OR. N.LE.0 ) X $ RETURN X* X IF( LSAME( TRANS, 'N' ) ) THEN X TRANST = 'T' X ELSE X TRANST = 'N' X END IF X* X IF( LSAME( STOREV, 'C' ) ) THEN X* X IF( LSAME( DIRECT, 'F' ) ) THEN X* X* Let V = ( V1 ) (first K rows) X* ( V2 ) X* where V1 is unit lower triangular. X* X IF( LSAME( SIDE, 'L' ) ) THEN X* X* Form H * C or H' * C where C = ( C1 ) X* ( C2 ) X* X* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) X* X* W := C1' X* X DO 10 J = 1, K X CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) X 10 CONTINUE X* X* W := W * V1 X* X CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, X $ K, ONE, V, LDV, WORK, LDWORK ) X IF( M.GT.K ) THEN X* X* W := W + C2'*V2 X* X CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K, X $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV, X $ ONE, WORK, LDWORK ) X END IF X* X* W := W * T' or W * T X* X CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, X $ ONE, T, LDT, WORK, LDWORK ) X* X* C := C - V * W' X* X IF( M.GT.K ) THEN X* X* C2 := C2 - V2 * W' X* X CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K, X $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE, X $ C( K+1, 1 ), LDC ) X END IF X* X* W := W * V1' X* X CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, X $ ONE, V, LDV, WORK, LDWORK ) X* X* C1 := C1 - W' X* X DO 30 J = 1, K X DO 20 I = 1, N X C( J, I ) = C( J, I ) - WORK( I, J ) X 20 CONTINUE X 30 CONTINUE X* X ELSE IF( LSAME( SIDE, 'R' ) ) THEN X* X* Form C * H or C * H' where C = ( C1 C2 ) X* X* W := C * V = (C1*V1 + C2*V2) (stored in WORK) X* X* W := C1 X* X DO 40 J = 1, K X CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) X 40 CONTINUE X* X* W := W * V1 X* X CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, X $ K, ONE, V, LDV, WORK, LDWORK ) X IF( N.GT.K ) THEN X* X* W := W + C2 * V2 X* X CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K, X $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, X $ ONE, WORK, LDWORK ) X END IF X* X* W := W * T or W * T' X* X CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, X $ ONE, T, LDT, WORK, LDWORK ) X* X* C := C - W * V' X* X IF( N.GT.K ) THEN X* X* C2 := C2 - W * V2' X* X CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K, X $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE, X $ C( 1, K+1 ), LDC ) X END IF X* X* W := W * V1' X* X CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, X $ ONE, V, LDV, WORK, LDWORK ) X* X* C1 := C1 - W X* X DO 60 J = 1, K X DO 50 I = 1, M X C( I, J ) = C( I, J ) - WORK( I, J ) X 50 CONTINUE X 60 CONTINUE X END IF X* X ELSE X* X* Let V = ( V1 ) X* ( V2 ) (last K rows) X* where V2 is unit upper triangular. X* X IF( LSAME( SIDE, 'L' ) ) THEN X* X* Form H * C or H' * C where C = ( C1 ) X* ( C2 ) X* X* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) X* X* W := C2' X* X DO 70 J = 1, K X CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) X 70 CONTINUE X* X* W := W * V2 X* X CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, X $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) X IF( M.GT.K ) THEN X* X* W := W + C1'*V1 X* X CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K, X $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) X END IF X* X* W := W * T' or W * T X* X CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, X $ ONE, T, LDT, WORK, LDWORK ) X* X* C := C - V * W' X* X IF( M.GT.K ) THEN X* X* C1 := C1 - V1 * W' X* X CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K, X $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC ) X END IF X* X* W := W * V2' X* X CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, X $ ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) X* X* C2 := C2 - W' X* X DO 90 J = 1, K X DO 80 I = 1, N X C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J ) X 80 CONTINUE X 90 CONTINUE X* X ELSE IF( LSAME( SIDE, 'R' ) ) THEN X* X* Form C * H or C * H' where C = ( C1 C2 ) X* X* W := C * V = (C1*V1 + C2*V2) (stored in WORK) X* X* W := C2 X* X DO 100 J = 1, K X CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) X 100 CONTINUE X* X* W := W * V2 X* X CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, X $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) X IF( N.GT.K ) THEN X* X* W := W + C1 * V1 X* X CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K, X $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) X END IF X* X* W := W * T or W * T' X* X CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, X $ ONE, T, LDT, WORK, LDWORK ) X* X* C := C - W * V' X* X IF( N.GT.K ) THEN X* X* C1 := C1 - W * V1' X* X CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K, X $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) X END IF X* X* W := W * V2' X* X CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, X $ ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) X* X* C2 := C2 - W X* X DO 120 J = 1, K X DO 110 I = 1, M X C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) X 110 CONTINUE X 120 CONTINUE X END IF X END IF X* X ELSE IF( LSAME( STOREV, 'R' ) ) THEN X* X IF( LSAME( DIRECT, 'F' ) ) THEN X* X* Let V = ( V1 V2 ) (V1: first K columns) X* where V1 is unit upper triangular. X* X IF( LSAME( SIDE, 'L' ) ) THEN X* X* Form H * C or H' * C where C = ( C1 ) X* ( C2 ) X* X* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) X* X* W := C1' X* X DO 130 J = 1, K X CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) X 130 CONTINUE X* X* W := W * V1' X* X CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, X $ ONE, V, LDV, WORK, LDWORK ) X IF( M.GT.K ) THEN X* X* W := W + C2'*V2' X* X CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, X $ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE, X $ WORK, LDWORK ) X END IF X* X* W := W * T' or W * T X* X CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, X $ ONE, T, LDT, WORK, LDWORK ) X* X* C := C - V' * W' X* X IF( M.GT.K ) THEN X* X* C2 := C2 - V2' * W' X* X CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE, X $ V( 1, K+1 ), LDV, WORK, LDWORK, ONE, X $ C( K+1, 1 ), LDC ) X END IF X* X* W := W * V1 X* X CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, X $ K, ONE, V, LDV, WORK, LDWORK ) X* X* C1 := C1 - W' X* X DO 150 J = 1, K X DO 140 I = 1, N X C( J, I ) = C( J, I ) - WORK( I, J ) X 140 CONTINUE X 150 CONTINUE X* X ELSE IF( LSAME( SIDE, 'R' ) ) THEN X* X* Form C * H or C * H' where C = ( C1 C2 ) X* X* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) X* X* W := C1 X* X DO 160 J = 1, K X CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) X 160 CONTINUE X* X* W := W * V1' X* X CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, X $ ONE, V, LDV, WORK, LDWORK ) X IF( N.GT.K ) THEN X* X* W := W + C2 * V2' X* X CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K, X $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV, X $ ONE, WORK, LDWORK ) X END IF X* X* W := W * T or W * T' X* X CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, X $ ONE, T, LDT, WORK, LDWORK ) X* X* C := C - W * V X* X IF( N.GT.K ) THEN X* X* C2 := C2 - W * V2 X* X CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K, X $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE, X $ C( 1, K+1 ), LDC ) X END IF X* X* W := W * V1 X* X CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, X $ K, ONE, V, LDV, WORK, LDWORK ) X* X* C1 := C1 - W X* X DO 180 J = 1, K X DO 170 I = 1, M X C( I, J ) = C( I, J ) - WORK( I, J ) X 170 CONTINUE X 180 CONTINUE X* X END IF X* X ELSE X* X* Let V = ( V1 V2 ) (V2: last K columns) X* where V2 is unit lower triangular. X* X IF( LSAME( SIDE, 'L' ) ) THEN X* X* Form H * C or H' * C where C = ( C1 ) X* ( C2 ) X* X* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) X* X* W := C2' X* X DO 190 J = 1, K X CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) X 190 CONTINUE X* X* W := W * V2' X* X CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, X $ ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) X IF( M.GT.K ) THEN X* X* W := W + C1'*V1' X* X CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, X $ C, LDC, V, LDV, ONE, WORK, LDWORK ) X END IF X* X* W := W * T' or W * T X* X CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, X $ ONE, T, LDT, WORK, LDWORK ) X* X* C := C - V' * W' X* X IF( M.GT.K ) THEN X* X* C1 := C1 - V1' * W' X* X CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE, X $ V, LDV, WORK, LDWORK, ONE, C, LDC ) X END IF X* X* W := W * V2 X* X CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, X $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) X* X* C2 := C2 - W' X* X DO 210 J = 1, K X DO 200 I = 1, N X C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J ) X 200 CONTINUE X 210 CONTINUE X* X ELSE IF( LSAME( SIDE, 'R' ) ) THEN X* X* Form C * H or C * H' where C = ( C1 C2 ) X* X* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) X* X* W := C2 X* X DO 220 J = 1, K X CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) X 220 CONTINUE X* X* W := W * V2' X* X CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, X $ ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) X IF( N.GT.K ) THEN X* X* W := W + C1 * V1' X* X CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K, X $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) X END IF X* X* W := W * T or W * T' X* X CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, X $ ONE, T, LDT, WORK, LDWORK ) X* X* C := C - W * V X* X IF( N.GT.K ) THEN X* X* C1 := C1 - W * V1 X* X CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K, X $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) X END IF X* X* W := W * V2 X* X CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, X $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) X* X* C1 := C1 - W X* X DO 240 J = 1, K X DO 230 I = 1, M X C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) X 230 CONTINUE X 240 CONTINUE X* X END IF X* X END IF X END IF X* X RETURN X* X* End of DLARFB X* X END X SUBROUTINE DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, X $ WORK, INFO ) X* X* -- LAPACK routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* February 29, 1992 X* X* .. Scalar Arguments .. X CHARACTER SIDE, TRANS X INTEGER INFO, K, LDA, LDC, M, N X* .. X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) X* .. X* X* Purpose X* ======= X* X* DORM2L overwrites the general real m by n matrix C with X* X* Q * C if SIDE = 'L' and TRANS = 'N', or X* X* Q'* C if SIDE = 'L' and TRANS = 'T', or X* X* C * Q if SIDE = 'R' and TRANS = 'N', or X* X* C * Q' if SIDE = 'R' and TRANS = 'T', X* X* where Q is a real orthogonal matrix defined as the product of k X* elementary reflectors X* X* Q = H(k) . . . H(2) H(1) X* X* as returned by DGEQLF. Q is of order m if SIDE = 'L' and of order n X* if SIDE = 'R'. X* X* Arguments X* ========= X* X* SIDE (input) CHARACTER*1 X* = 'L': apply Q or Q' from the Left X* = 'R': apply Q or Q' from the Right X* X* TRANS (input) CHARACTER*1 X* = 'N': apply Q (No transpose) X* = 'T': apply Q' (Transpose) X* X* M (input) INTEGER X* The number of rows of the matrix C. M >= 0. X* X* N (input) INTEGER X* The number of columns of the matrix C. N >= 0. X* X* K (input) INTEGER X* The number of elementary reflectors whose product defines X* the matrix Q. X* If SIDE = 'L', M >= K >= 0; X* if SIDE = 'R', N >= K >= 0. X* X* A (input) DOUBLE PRECISION array, dimension (LDA,K) X* The i-th column must contain the vector which defines the X* elementary reflector H(i), for i = 1,2,...,k, as returned by X* DGEQLF in the last k columns of its array argument A. X* A is modified by the routine but restored on exit. X* X* LDA (input) INTEGER X* The leading dimension of the array A. X* If SIDE = 'L', LDA >= max(1,M); X* if SIDE = 'R', LDA >= max(1,N). X* X* TAU (input) DOUBLE PRECISION array, dimension (K) X* TAU(i) must contain the scalar factor of the elementary X* reflector H(i), as returned by DGEQLF. X* X* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) X* On entry, the m by n matrix C. X* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. X* X* LDC (input) INTEGER X* The leading dimension of the array C. LDC >= max(1,M). X* X* WORK (workspace) DOUBLE PRECISION array, dimension X* (N) if SIDE = 'L', X* (M) if SIDE = 'R' X* X* INFO (output) INTEGER X* = 0: successful exit X* < 0: if INFO = -i, the i-th argument had an illegal value X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ONE X PARAMETER ( ONE = 1.0D+0 ) X* .. X* .. Local Scalars .. X LOGICAL LEFT, NOTRAN X INTEGER I, I1, I2, I3, MI, NI, NQ X DOUBLE PRECISION AII X* .. X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. X* .. External Subroutines .. X EXTERNAL DLARF, XERBLA X* .. X* .. Intrinsic Functions .. X INTRINSIC MAX X* .. X* .. Executable Statements .. X* X* Test the input arguments X* X INFO = 0 X LEFT = LSAME( SIDE, 'L' ) X NOTRAN = LSAME( TRANS, 'N' ) X* X* NQ is the order of Q X* X IF( LEFT ) THEN X NQ = M X ELSE X NQ = N X END IF X IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN X INFO = -1 X ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN X INFO = -2 X ELSE IF( M.LT.0 ) THEN X INFO = -3 X ELSE IF( N.LT.0 ) THEN X INFO = -4 X ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN X INFO = -5 X ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN X INFO = -7 X ELSE IF( LDC.LT.MAX( 1, M ) ) THEN X INFO = -10 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DORM2L', -INFO ) X RETURN X END IF X* X* Quick return if possible X* X IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) X $ RETURN X* X IF( ( LEFT .AND. NOTRAN ) .OR. ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) X $ THEN X I1 = 1 X I2 = K X I3 = 1 X ELSE X I1 = K X I2 = 1 X I3 = -1 X END IF X* X IF( LEFT ) THEN X NI = N X ELSE X MI = M X END IF X* X DO 10 I = I1, I2, I3 X IF( LEFT ) THEN X* X* H(i) is applied to C(1:m-k+i,1:n) X* X MI = M - K + I X ELSE X* X* H(i) is applied to C(1:m,1:n-k+i) X* X NI = N - K + I X END IF X* X* Apply H(i) X* X AII = A( NQ-K+I, I ) X A( NQ-K+I, I ) = ONE X CALL DLARF( SIDE, MI, NI, A( 1, I ), 1, TAU( I ), C, LDC, X $ WORK ) X A( NQ-K+I, I ) = AII X 10 CONTINUE X RETURN X* X* End of DORM2L X* X END X SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, X $ WORK, INFO ) X* X* -- LAPACK routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* February 29, 1992 X* X* .. Scalar Arguments .. X CHARACTER SIDE, TRANS X INTEGER INFO, K, LDA, LDC, M, N X* .. X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) X* .. X* X* Purpose X* ======= X* X* DORM2R overwrites the general real m by n matrix C with X* X* Q * C if SIDE = 'L' and TRANS = 'N', or X* X* Q'* C if SIDE = 'L' and TRANS = 'T', or X* X* C * Q if SIDE = 'R' and TRANS = 'N', or X* X* C * Q' if SIDE = 'R' and TRANS = 'T', X* X* where Q is a real orthogonal matrix defined as the product of k X* elementary reflectors X* X* Q = H(1) H(2) . . . H(k) X* X* as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n X* if SIDE = 'R'. X* X* Arguments X* ========= X* X* SIDE (input) CHARACTER*1 X* = 'L': apply Q or Q' from the Left X* = 'R': apply Q or Q' from the Right X* X* TRANS (input) CHARACTER*1 X* = 'N': apply Q (No transpose) X* = 'T': apply Q' (Transpose) X* X* M (input) INTEGER X* The number of rows of the matrix C. M >= 0. X* X* N (input) INTEGER X* The number of columns of the matrix C. N >= 0. X* X* K (input) INTEGER X* The number of elementary reflectors whose product defines X* the matrix Q. X* If SIDE = 'L', M >= K >= 0; X* if SIDE = 'R', N >= K >= 0. X* X* A (input) DOUBLE PRECISION array, dimension (LDA,K) X* The i-th column must contain the vector which defines the X* elementary reflector H(i), for i = 1,2,...,k, as returned by X* DGEQRF in the first k columns of its array argument A. X* A is modified by the routine but restored on exit. X* X* LDA (input) INTEGER X* The leading dimension of the array A. X* If SIDE = 'L', LDA >= max(1,M); X* if SIDE = 'R', LDA >= max(1,N). X* X* TAU (input) DOUBLE PRECISION array, dimension (K) X* TAU(i) must contain the scalar factor of the elementary X* reflector H(i), as returned by DGEQRF. X* X* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) X* On entry, the m by n matrix C. X* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. X* X* LDC (input) INTEGER X* The leading dimension of the array C. LDC >= max(1,M). X* X* WORK (workspace) DOUBLE PRECISION array, dimension X* (N) if SIDE = 'L', X* (M) if SIDE = 'R' X* X* INFO (output) INTEGER X* = 0: successful exit X* < 0: if INFO = -i, the i-th argument had an illegal value X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ONE X PARAMETER ( ONE = 1.0D+0 ) X* .. X* .. Local Scalars .. X LOGICAL LEFT, NOTRAN X INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ X DOUBLE PRECISION AII X* .. X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. X* .. External Subroutines .. X EXTERNAL DLARF, XERBLA X* .. X* .. Intrinsic Functions .. X INTRINSIC MAX X* .. X* .. Executable Statements .. X* X* Test the input arguments X* X INFO = 0 X LEFT = LSAME( SIDE, 'L' ) X NOTRAN = LSAME( TRANS, 'N' ) X* X* NQ is the order of Q X* X IF( LEFT ) THEN X NQ = M X ELSE X NQ = N X END IF X IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN X INFO = -1 X ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN X INFO = -2 X ELSE IF( M.LT.0 ) THEN X INFO = -3 X ELSE IF( N.LT.0 ) THEN X INFO = -4 X ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN X INFO = -5 X ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN X INFO = -7 X ELSE IF( LDC.LT.MAX( 1, M ) ) THEN X INFO = -10 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DORM2R', -INFO ) X RETURN X END IF X* X* Quick return if possible X* X IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) X $ RETURN X* X IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) ) X $ THEN X I1 = 1 X I2 = K X I3 = 1 X ELSE X I1 = K X I2 = 1 X I3 = -1 X END IF X* X IF( LEFT ) THEN X NI = N X JC = 1 X ELSE X MI = M X IC = 1 X END IF X* X DO 10 I = I1, I2, I3 X IF( LEFT ) THEN X* X* H(i) is applied to C(i:m,1:n) X* X MI = M - I + 1 X IC = I X ELSE X* X* H(i) is applied to C(1:m,i:n) X* X NI = N - I + 1 X JC = I X END IF X* X* Apply H(i) X* X AII = A( I, I ) X A( I, I ) = ONE X CALL DLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, JC ), X $ LDC, WORK ) X A( I, I ) = AII X 10 CONTINUE X RETURN X* X* End of DORM2R X* X END X SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) X* X* -- LAPACK auxiliary routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* February 29, 1992 X* X* .. Scalar Arguments .. X CHARACTER DIRECT, STOREV X INTEGER K, LDT, LDV, N X* .. X* .. Array Arguments .. X DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) X* .. X* X* Purpose X* ======= X* X* DLARFT forms the triangular factor T of a real block reflector H X* of order n, which is defined as a product of k elementary reflectors. X* X* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; X* X* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. X* X* If STOREV = 'C', the vector which defines the elementary reflector X* H(i) is stored in the i-th column of the array V, and X* X* H = I - V * T * V' X* X* If STOREV = 'R', the vector which defines the elementary reflector X* H(i) is stored in the i-th row of the array V, and X* X* H = I - V' * T * V X* X* Arguments X* ========= X* X* DIRECT (input) CHARACTER*1 X* Specifies the order in which the elementary reflectors are X* multiplied to form the block reflector: X* = 'F': H = H(1) H(2) . . . H(k) (Forward) X* = 'B': H = H(k) . . . H(2) H(1) (Backward) X* X* STOREV (input) CHARACTER*1 X* Specifies how the vectors which define the elementary X* reflectors are stored (see also Further Details): X* = 'C': columnwise X* = 'R': rowwise X* X* N (input) INTEGER X* The order of the block reflector H. N >= 0. X* X* K (input) INTEGER X* The order of the triangular factor T (= the number of X* elementary reflectors). K >= 1. X* X* V (input/output) DOUBLE PRECISION array, dimension X* (LDV,K) if STOREV = 'C' X* (LDV,N) if STOREV = 'R' X* The matrix V. See further details. X* X* LDV (input) INTEGER X* The leading dimension of the array V. X* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. X* X* TAU (input) DOUBLE PRECISION array, dimension (K) X* TAU(i) must contain the scalar factor of the elementary X* reflector H(i). X* X* T (output) DOUBLE PRECISION array, dimension (LDT,K) X* The k by k triangular factor T of the block reflector. X* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is X* lower triangular. The rest of the array is not used. X* X* LDT (input) INTEGER X* The leading dimension of the array T. LDT >= K. X* X* Further Details X* =============== X* X* The shape of the matrix V and the storage of the vectors which define X* the H(i) is best illustrated by the following example with n = 5 and X* k = 3. The elements equal to 1 are not stored; the corresponding X* array elements are modified but restored on exit. The rest of the X* array is not used. X* X* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': X* X* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) X* ( v1 1 ) ( 1 v2 v2 v2 ) X* ( v1 v2 1 ) ( 1 v3 v3 ) X* ( v1 v2 v3 ) X* ( v1 v2 v3 ) X* X* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': X* X* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) X* ( v1 v2 v3 ) ( v2 v2 v2 1 ) X* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) X* ( 1 v3 ) X* ( 1 ) X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ONE, ZERO X PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) X* .. X* .. Local Scalars .. X INTEGER I, J X DOUBLE PRECISION VII X* .. X* .. External Subroutines .. X EXTERNAL DGEMV, DTRMV X* .. X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. X* .. Executable Statements .. X* X* Quick return if possible X* X IF( N.EQ.0 ) X $ RETURN X* X IF( LSAME( DIRECT, 'F' ) ) THEN X DO 20 I = 1, K X IF( TAU( I ).EQ.ZERO ) THEN X* X* H(i) = I X* X DO 10 J = 1, I X T( J, I ) = ZERO X 10 CONTINUE X ELSE X* X* general case X* X VII = V( I, I ) X V( I, I ) = ONE X IF( LSAME( STOREV, 'C' ) ) THEN X* X* T(1:i-1,i) := - tau(i) * V(i:n,1:i-1)' * V(i:n,i) X* X CALL DGEMV( 'Transpose', N-I+1, I-1, -TAU( I ), X $ V( I, 1 ), LDV, V( I, I ), 1, ZERO, X $ T( 1, I ), 1 ) X ELSE X* X* T(1:i-1,i) := - tau(i) * V(1:i-1,i:n) * V(i,i:n)' X* X CALL DGEMV( 'No transpose', I-1, N-I+1, -TAU( I ), X $ V( 1, I ), LDV, V( I, I ), LDV, ZERO, X $ T( 1, I ), 1 ) X END IF X V( I, I ) = VII X* X* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) X* X CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, X $ LDT, T( 1, I ), 1 ) X T( I, I ) = TAU( I ) X END IF X 20 CONTINUE X ELSE X DO 40 I = K, 1, -1 X IF( TAU( I ).EQ.ZERO ) THEN X* X* H(i) = I X* X DO 30 J = I, K X T( J, I ) = ZERO X 30 CONTINUE X ELSE X* X* general case X* X IF( I.LT.K ) THEN X IF( LSAME( STOREV, 'C' ) ) THEN X VII = V( N-K+I, I ) X V( N-K+I, I ) = ONE X* X* T(i+1:k,i) := X* - tau(i) * V(1:n-k+i,i+1:k)' * V(1:n-k+i,i) X* X CALL DGEMV( 'Transpose', N-K+I, K-I, -TAU( I ), X $ V( 1, I+1 ), LDV, V( 1, I ), 1, ZERO, X $ T( I+1, I ), 1 ) X V( N-K+I, I ) = VII X ELSE X VII = V( I, N-K+I ) X V( I, N-K+I ) = ONE X* X* T(i+1:k,i) := X* - tau(i) * V(i+1:k,1:n-k+i) * V(i,1:n-k+i)' X* X CALL DGEMV( 'No transpose', K-I, N-K+I, -TAU( I ), X $ V( I+1, 1 ), LDV, V( I, 1 ), LDV, ZERO, X $ T( I+1, I ), 1 ) X V( I, N-K+I ) = VII X END IF X* X* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) X* X CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, X $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) X END IF X T( I, I ) = TAU( I ) X END IF X 40 CONTINUE X END IF X RETURN X* X* End of DLARFT X* X END X SUBROUTINE DLARNV( IDIST, ISEED, N, X ) X* X* -- LAPACK auxiliary routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* September 30, 1994 X* X* .. Scalar Arguments .. X INTEGER IDIST, N X* .. X* .. Array Arguments .. X INTEGER ISEED( 4 ) X DOUBLE PRECISION X( * ) X* .. X* X* Purpose X* ======= X* X* DLARNV returns a vector of n random real numbers from a uniform or X* normal distribution. X* X* Arguments X* ========= X* X* IDIST (input) INTEGER X* Specifies the distribution of the random numbers: X* = 1: uniform (0,1) X* = 2: uniform (-1,1) X* = 3: normal (0,1) X* X* ISEED (input/output) INTEGER array, dimension (4) X* On entry, the seed of the random number generator; the array X* elements must be between 0 and 4095, and ISEED(4) must be X* odd. X* On exit, the seed is updated. X* X* N (input) INTEGER X* The number of random numbers to be generated. X* X* X (output) DOUBLE PRECISION array, dimension (N) X* The generated random numbers. X* X* Further Details X* =============== X* X* This routine calls the auxiliary routine DLARUV to generate random X* real numbers from a uniform (0,1) distribution, in batches of up to X* 128 using vectorisable code. The Box-Muller method is used to X* transform numbers from a uniform to a normal distribution. X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ONE, TWO X PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0 ) X INTEGER LV X PARAMETER ( LV = 128 ) X DOUBLE PRECISION TWOPI X PARAMETER ( TWOPI = 6.2831853071795864769252867663D+0 ) X* .. X* .. Local Scalars .. X INTEGER I, IL, IL2, IV X* .. X* .. Local Arrays .. X DOUBLE PRECISION U( LV ) X* .. X* .. Intrinsic Functions .. X INTRINSIC COS, LOG, MIN, SQRT X* .. X* .. External Subroutines .. X EXTERNAL DLARUV X* .. X* .. Executable Statements .. X* X DO 40 IV = 1, N, LV / 2 X IL = MIN( LV / 2, N-IV+1 ) X IF( IDIST.EQ.3 ) THEN X IL2 = 2*IL X ELSE X IL2 = IL X END IF X* X* Call DLARUV to generate IL2 numbers from a uniform (0,1) X* distribution (IL2 <= LV) X* X CALL DLARUV( ISEED, IL2, U ) X* X IF( IDIST.EQ.1 ) THEN X* X* Copy generated numbers X* X DO 10 I = 1, IL X X( IV+I-1 ) = U( I ) X 10 CONTINUE X ELSE IF( IDIST.EQ.2 ) THEN X* X* Convert generated numbers to uniform (-1,1) distribution X* X DO 20 I = 1, IL X X( IV+I-1 ) = TWO*U( I ) - ONE X 20 CONTINUE X ELSE IF( IDIST.EQ.3 ) THEN X* X* Convert generated numbers to normal (0,1) distribution X* X DO 30 I = 1, IL X X( IV+I-1 ) = SQRT( -TWO*LOG( U( 2*I-1 ) ) )* X $ COS( TWOPI*U( 2*I ) ) X 30 CONTINUE X END IF X 40 CONTINUE X RETURN X* X* End of DLARNV X* X END X* X INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, X $ N4 ) X* X* -- LAPACK auxiliary routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* September 30, 1994 X* X* .. Scalar Arguments .. X CHARACTER*( * ) NAME, OPTS X INTEGER ISPEC, N1, N2, N3, N4 X* .. X* X* Purpose X* ======= X* X* ILAENV is called from the LAPACK routines to choose problem-dependent X* parameters for the local environment. See ISPEC for a description of X* the parameters. X* X* This version provides a set of parameters which should give good, X* but not optimal, performance on many of the currently available X* computers. Users are encouraged to modify this subroutine to set X* the tuning parameters for their particular machine using the option X* and problem size information in the arguments. X* X* This routine will not function correctly if it is converted to all X* lower case. Converting it to all upper case is allowed. X* X* Arguments X* ========= X* X* ISPEC (input) INTEGER X* Specifies the parameter to be returned as the value of X* ILAENV. X* = 1: the optimal blocksize; if this value is 1, an unblocked X* algorithm will give the best performance. X* = 2: the minimum block size for which the block routine X* should be used; if the usable block size is less than X* this value, an unblocked routine should be used. X* = 3: the crossover point (in a block routine, for N less X* than this value, an unblocked routine should be used) X* = 4: the number of shifts, used in the nonsymmetric X* eigenvalue routines X* = 5: the minimum column dimension for blocking to be used; X* rectangular blocks must have dimension at least k by m, X* where k is given by ILAENV(2,...) and m by ILAENV(5,...) X* = 6: the crossover point for the SVD (when reducing an m by n X* matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds X* this value, a QR factorization is used first to reduce X* the matrix to a triangular form.) X* = 7: the number of processors X* = 8: the crossover point for the multishift QR and QZ methods X* for nonsymmetric eigenvalue problems. X* X* NAME (input) CHARACTER*(*) X* The name of the calling subroutine, in either upper case or X* lower case. X* X* OPTS (input) CHARACTER*(*) X* The character options to the subroutine NAME, concatenated X* into a single character string. For example, UPLO = 'U', X* TRANS = 'T', and DIAG = 'N' for a triangular routine would X* be specified as OPTS = 'UTN'. X* X* N1 (input) INTEGER X* N2 (input) INTEGER X* N3 (input) INTEGER X* N4 (input) INTEGER X* Problem dimensions for the subroutine NAME; these may not all X* be required. X* X* (ILAENV) (output) INTEGER X* >= 0: the value of the parameter specified by ISPEC X* < 0: if ILAENV = -k, the k-th argument had an illegal value. X* X* Further Details X* =============== X* X* The following conventions have been used when calling ILAENV from the X* LAPACK routines: X* 1) OPTS is a concatenation of all of the character options to X* subroutine NAME, in the same order that they appear in the X* argument list for NAME, even if they are not used in determining X* the value of the parameter specified by ISPEC. X* 2) The problem dimensions N1, N2, N3, N4 are specified in the order X* that they appear in the argument list for NAME. N1 is used X* first, N2 second, and so on, and unused problem dimensions are X* passed a value of -1. X* 3) The parameter value returned by ILAENV is checked for validity in X* the calling subroutine. For example, ILAENV is used to retrieve X* the optimal blocksize for STRTRI as follows: X* X* NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) X* IF( NB.LE.1 ) NB = MAX( 1, N ) X* X* ===================================================================== X* X* .. Local Scalars .. X LOGICAL CNAME, SNAME X CHARACTER*1 C1 X CHARACTER*2 C2, C4 X CHARACTER*3 C3 X CHARACTER*6 SUBNAM X INTEGER I, IC, IZ, NB, NBMIN, NX X* .. X* .. Intrinsic Functions .. X INTRINSIC CHAR, ICHAR, INT, MIN, REAL X* .. X* .. Executable Statements .. X* X GO TO ( 100, 100, 100, 400, 500, 600, 700, 800 ) ISPEC X* X* Invalid value for ISPEC X* X ILAENV = -1 X RETURN X* X 100 CONTINUE X* X* Convert NAME to upper case if the first character is lower case. X* X ILAENV = 1 X SUBNAM = NAME X IC = ICHAR( SUBNAM( 1:1 ) ) X IZ = ICHAR( 'Z' ) X IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN X* X* ASCII character set X* X IF( IC.GE.97 .AND. IC.LE.122 ) THEN X SUBNAM( 1:1 ) = CHAR( IC-32 ) X DO 10 I = 2, 6 X IC = ICHAR( SUBNAM( I:I ) ) X IF( IC.GE.97 .AND. IC.LE.122 ) X $ SUBNAM( I:I ) = CHAR( IC-32 ) X 10 CONTINUE X END IF X* X ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN X* X* EBCDIC character set X* X IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. X $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. X $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN X SUBNAM( 1:1 ) = CHAR( IC+64 ) X DO 20 I = 2, 6 X IC = ICHAR( SUBNAM( I:I ) ) X IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. X $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. X $ ( IC.GE.162 .AND. IC.LE.169 ) ) X $ SUBNAM( I:I ) = CHAR( IC+64 ) X 20 CONTINUE X END IF X* X ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN X* X* Prime machines: ASCII+128 X* X IF( IC.GE.225 .AND. IC.LE.250 ) THEN X SUBNAM( 1:1 ) = CHAR( IC-32 ) X DO 30 I = 2, 6 X IC = ICHAR( SUBNAM( I:I ) ) X IF( IC.GE.225 .AND. IC.LE.250 ) X $ SUBNAM( I:I ) = CHAR( IC-32 ) X 30 CONTINUE X END IF X END IF X* X C1 = SUBNAM( 1:1 ) X SNAME = C1.EQ.'S' .OR. C1.EQ.'D' X CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' X IF( .NOT.( CNAME .OR. SNAME ) ) X $ RETURN X C2 = SUBNAM( 2:3 ) X C3 = SUBNAM( 4:6 ) X C4 = C3( 2:3 ) X* X GO TO ( 110, 200, 300 ) ISPEC X* X 110 CONTINUE X* X* ISPEC = 1: block size X* X* In these examples, separate code is provided for setting NB for X* real and complex. We assume that NB will take the same value in X* single or double precision. X* X NB = 1 X* X IF( C2.EQ.'GE' ) THEN X IF( C3.EQ.'TRF' ) THEN X IF( SNAME ) THEN X NB = 64 X ELSE X NB = 64 X END IF X ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. X $ C3.EQ.'QLF' ) THEN X IF( SNAME ) THEN X NB = 32 X ELSE X NB = 32 X END IF X ELSE IF( C3.EQ.'HRD' ) THEN X IF( SNAME ) THEN X NB = 32 X ELSE X NB = 32 X END IF X ELSE IF( C3.EQ.'BRD' ) THEN X IF( SNAME ) THEN X NB = 32 X ELSE X NB = 32 X END IF X ELSE IF( C3.EQ.'TRI' ) THEN X IF( SNAME ) THEN X NB = 64 X ELSE X NB = 64 X END IF X END IF X ELSE IF( C2.EQ.'PO' ) THEN X IF( C3.EQ.'TRF' ) THEN X IF( SNAME ) THEN X NB = 64 X ELSE X NB = 64 X END IF X END IF X ELSE IF( C2.EQ.'SY' ) THEN X IF( C3.EQ.'TRF' ) THEN X IF( SNAME ) THEN X NB = 64 X ELSE X NB = 64 X END IF X ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN X NB = 1 X ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN X NB = 64 X END IF X ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN X IF( C3.EQ.'TRF' ) THEN X NB = 64 X ELSE IF( C3.EQ.'TRD' ) THEN X NB = 1 X ELSE IF( C3.EQ.'GST' ) THEN X NB = 64 X END IF X ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN X IF( C3( 1:1 ).EQ.'G' ) THEN X IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. X $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. X $ C4.EQ.'BR' ) THEN X NB = 32 X END IF X ELSE IF( C3( 1:1 ).EQ.'M' ) THEN X IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. X $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. X $ C4.EQ.'BR' ) THEN X NB = 32 X END IF X END IF X ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN X IF( C3( 1:1 ).EQ.'G' ) THEN X IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. X $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. X $ C4.EQ.'BR' ) THEN X NB = 32 X END IF X ELSE IF( C3( 1:1 ).EQ.'M' ) THEN X IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. X $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. X $ C4.EQ.'BR' ) THEN X NB = 32 X END IF X END IF X ELSE IF( C2.EQ.'GB' ) THEN X IF( C3.EQ.'TRF' ) THEN X IF( SNAME ) THEN X IF( N4.LE.64 ) THEN X NB = 1 X ELSE X NB = 32 X END IF X ELSE X IF( N4.LE.64 ) THEN X NB = 1 X ELSE X NB = 32 X END IF X END IF X END IF X ELSE IF( C2.EQ.'PB' ) THEN X IF( C3.EQ.'TRF' ) THEN X IF( SNAME ) THEN X IF( N2.LE.64 ) THEN X NB = 1 X ELSE X NB = 32 X END IF X ELSE X IF( N2.LE.64 ) THEN X NB = 1 X ELSE X NB = 32 X END IF X END IF X END IF X ELSE IF( C2.EQ.'TR' ) THEN X IF( C3.EQ.'TRI' ) THEN X IF( SNAME ) THEN X NB = 64 X ELSE X NB = 64 X END IF X END IF X ELSE IF( C2.EQ.'LA' ) THEN X IF( C3.EQ.'UUM' ) THEN X IF( SNAME ) THEN X NB = 64 X ELSE X NB = 64 X END IF X END IF X ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN X IF( C3.EQ.'EBZ' ) THEN X NB = 1 X END IF X END IF X ILAENV = NB X RETURN X* X 200 CONTINUE X* X* ISPEC = 2: minimum block size X* X NBMIN = 2 X IF( C2.EQ.'GE' ) THEN X IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. X $ C3.EQ.'QLF' ) THEN X IF( SNAME ) THEN X NBMIN = 2 X ELSE X NBMIN = 2 X END IF X ELSE IF( C3.EQ.'HRD' ) THEN X IF( SNAME ) THEN X NBMIN = 2 X ELSE X NBMIN = 2 X END IF X ELSE IF( C3.EQ.'BRD' ) THEN X IF( SNAME ) THEN X NBMIN = 2 X ELSE X NBMIN = 2 X END IF X ELSE IF( C3.EQ.'TRI' ) THEN X IF( SNAME ) THEN X NBMIN = 2 X ELSE X NBMIN = 2 X END IF X END IF X ELSE IF( C2.EQ.'SY' ) THEN X IF( C3.EQ.'TRF' ) THEN X IF( SNAME ) THEN X NBMIN = 8 X ELSE X NBMIN = 8 X END IF X ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN X NBMIN = 2 X END IF X ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN X IF( C3.EQ.'TRD' ) THEN X NBMIN = 2 X END IF X ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN X IF( C3( 1:1 ).EQ.'G' ) THEN X IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. X $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. X $ C4.EQ.'BR' ) THEN X NBMIN = 2 X END IF X ELSE IF( C3( 1:1 ).EQ.'M' ) THEN X IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. X $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. X $ C4.EQ.'BR' ) THEN X NBMIN = 2 X END IF X END IF X ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN X IF( C3( 1:1 ).EQ.'G' ) THEN X IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. X $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. X $ C4.EQ.'BR' ) THEN X NBMIN = 2 X END IF X ELSE IF( C3( 1:1 ).EQ.'M' ) THEN X IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. X $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. X $ C4.EQ.'BR' ) THEN X NBMIN = 2 X END IF X END IF X END IF X ILAENV = NBMIN X RETURN X* X 300 CONTINUE X* X* ISPEC = 3: crossover point X* X NX = 0 X IF( C2.EQ.'GE' ) THEN X IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. X $ C3.EQ.'QLF' ) THEN X IF( SNAME ) THEN X NX = 128 X ELSE X NX = 128 X END IF X ELSE IF( C3.EQ.'HRD' ) THEN X IF( SNAME ) THEN X NX = 128 X ELSE X NX = 128 X END IF X ELSE IF( C3.EQ.'BRD' ) THEN X IF( SNAME ) THEN X NX = 128 X ELSE X NX = 128 X END IF X END IF X ELSE IF( C2.EQ.'SY' ) THEN X IF( SNAME .AND. C3.EQ.'TRD' ) THEN X NX = 1 X END IF X ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN X IF( C3.EQ.'TRD' ) THEN X NX = 1 X END IF X ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN X IF( C3( 1:1 ).EQ.'G' ) THEN X IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. X $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. X $ C4.EQ.'BR' ) THEN X NX = 128 X END IF X END IF X ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN X IF( C3( 1:1 ).EQ.'G' ) THEN X IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. X $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. X $ C4.EQ.'BR' ) THEN X NX = 128 X END IF X END IF X END IF X ILAENV = NX X RETURN X* X 400 CONTINUE X* X* ISPEC = 4: number of shifts (used by xHSEQR) X* X ILAENV = 6 X RETURN X* X 500 CONTINUE X* X* ISPEC = 5: minimum column dimension (not used) X* X ILAENV = 2 X RETURN X* X 600 CONTINUE X* X* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) X* X ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) X RETURN X* X 700 CONTINUE X* X* ISPEC = 7: number of processors (not used) X* X ILAENV = 1 X RETURN X* X 800 CONTINUE X* X* ISPEC = 8: crossover point for multishift (used by xHSEQR) X* X ILAENV = 50 X RETURN X* X* End of ILAENV X* X END X SUBROUTINE DLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) X* X* -- LAPACK auxiliary routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* October 31, 1992 X* X* .. Scalar Arguments .. X CHARACTER UPLO X INTEGER LDA, LDW, N, NB X* .. X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), E( * ), TAU( * ), W( LDW, * ) X* .. X* X* Purpose X* ======= X* X* DLATRD reduces NB rows and columns of a real symmetric matrix A to X* symmetric tridiagonal form by an orthogonal similarity X* transformation Q' * A * Q, and returns the matrices V and W which are X* needed to apply the transformation to the unreduced part of A. X* X* If UPLO = 'U', DLATRD reduces the last NB rows and columns of a X* matrix, of which the upper triangle is supplied; X* if UPLO = 'L', DLATRD reduces the first NB rows and columns of a X* matrix, of which the lower triangle is supplied. X* X* This is an auxiliary routine called by DSYTRD. X* X* Arguments X* ========= X* X* UPLO (input) CHARACTER X* Specifies whether the upper or lower triangular part of the X* symmetric matrix A is stored: X* = 'U': Upper triangular X* = 'L': Lower triangular X* X* N (input) INTEGER X* The order of the matrix A. X* X* NB (input) INTEGER X* The number of rows and columns to be reduced. X* X* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) X* On entry, the symmetric matrix A. If UPLO = 'U', the leading X* n-by-n upper triangular part of A contains the upper X* triangular part of the matrix A, and the strictly lower X* triangular part of A is not referenced. If UPLO = 'L', the X* leading n-by-n lower triangular part of A contains the lower X* triangular part of the matrix A, and the strictly upper X* triangular part of A is not referenced. X* On exit: X* if UPLO = 'U', the last NB columns have been reduced to X* tridiagonal form, with the diagonal elements overwriting X* the diagonal elements of A; the elements above the diagonal X* with the array TAU, represent the orthogonal matrix Q as a X* product of elementary reflectors; X* if UPLO = 'L', the first NB columns have been reduced to X* tridiagonal form, with the diagonal elements overwriting X* the diagonal elements of A; the elements below the diagonal X* with the array TAU, represent the orthogonal matrix Q as a X* product of elementary reflectors. X* See Further Details. X* X* LDA (input) INTEGER X* The leading dimension of the array A. LDA >= (1,N). X* X* E (output) DOUBLE PRECISION array, dimension (N-1) X* If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal X* elements of the last NB columns of the reduced matrix; X* if UPLO = 'L', E(1:nb) contains the subdiagonal elements of X* the first NB columns of the reduced matrix. X* X* TAU (output) DOUBLE PRECISION array, dimension (N-1) X* The scalar factors of the elementary reflectors, stored in X* TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'. X* See Further Details. X* X* W (output) DOUBLE PRECISION array, dimension (LDW,NB) X* The n-by-nb matrix W required to update the unreduced part X* of A. X* X* LDW (input) INTEGER X* The leading dimension of the array W. LDW >= max(1,N). X* X* Further Details X* =============== X* X* If UPLO = 'U', the matrix Q is represented as a product of elementary X* reflectors X* X* Q = H(n) H(n-1) . . . H(n-nb+1). X* X* Each H(i) has the form X* X* H(i) = I - tau * v * v' X* X* where tau is a real scalar, and v is a real vector with X* v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i), X* and tau in TAU(i-1). X* X* If UPLO = 'L', the matrix Q is represented as a product of elementary X* reflectors X* X* Q = H(1) H(2) . . . H(nb). X* X* Each H(i) has the form X* X* H(i) = I - tau * v * v' X* X* where tau is a real scalar, and v is a real vector with X* v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), X* and tau in TAU(i). X* X* The elements of the vectors v together form the n-by-nb matrix V X* which is needed, with W, to apply the transformation to the unreduced X* part of the matrix, using a symmetric rank-2k update of the form: X* A := A - V*W' - W*V'. X* X* The contents of A on exit are illustrated by the following examples X* with n = 5 and nb = 2: X* X* if UPLO = 'U': if UPLO = 'L': X* X* ( a a a v4 v5 ) ( d ) X* ( a a v4 v5 ) ( 1 d ) X* ( a 1 v5 ) ( v1 1 a ) X* ( d 1 ) ( v1 v2 a a ) X* ( d ) ( v1 v2 a a a ) X* X* where d denotes a diagonal element of the reduced matrix, a denotes X* an element of the original matrix that is unchanged, and vi denotes X* an element of the vector defining H(i). X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ZERO, ONE, HALF X PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) X* .. X* .. Local Scalars .. X INTEGER I, IW X DOUBLE PRECISION ALPHA X* .. X* .. External Subroutines .. X EXTERNAL DAXPY, DGEMV, DLARFG, DSCAL, DSYMV X* .. X* .. External Functions .. X LOGICAL LSAME X DOUBLE PRECISION DDOT X EXTERNAL LSAME, DDOT X* .. X* .. Intrinsic Functions .. X INTRINSIC MIN X* .. X* .. Executable Statements .. X* X* Quick return if possible X* X IF( N.LE.0 ) X $ RETURN X* X IF( LSAME( UPLO, 'U' ) ) THEN X* X* Reduce last NB columns of upper triangle X* X DO 10 I = N, N - NB + 1, -1 X IW = I - N + NB X IF( I.LT.N ) THEN X* X* Update A(1:i,i) X* X CALL DGEMV( 'No transpose', I, N-I, -ONE, A( 1, I+1 ), X $ LDA, W( I, IW+1 ), LDW, ONE, A( 1, I ), 1 ) X CALL DGEMV( 'No transpose', I, N-I, -ONE, W( 1, IW+1 ), X $ LDW, A( I, I+1 ), LDA, ONE, A( 1, I ), 1 ) X END IF X IF( I.GT.1 ) THEN X* X* Generate elementary reflector H(i) to annihilate X* A(1:i-2,i) X* X CALL DLARFG( I-1, A( I-1, I ), A( 1, I ), 1, TAU( I-1 ) ) X E( I-1 ) = A( I-1, I ) X A( I-1, I ) = ONE X* X* Compute W(1:i-1,i) X* X CALL DSYMV( 'Upper', I-1, ONE, A, LDA, A( 1, I ), 1, X $ ZERO, W( 1, IW ), 1 ) X IF( I.LT.N ) THEN X CALL DGEMV( 'Transpose', I-1, N-I, ONE, W( 1, IW+1 ), X $ LDW, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 ) X CALL DGEMV( 'No transpose', I-1, N-I, -ONE, X $ A( 1, I+1 ), LDA, W( I+1, IW ), 1, ONE, X $ W( 1, IW ), 1 ) X CALL DGEMV( 'Transpose', I-1, N-I, ONE, A( 1, I+1 ), X $ LDA, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 ) X CALL DGEMV( 'No transpose', I-1, N-I, -ONE, X $ W( 1, IW+1 ), LDW, W( I+1, IW ), 1, ONE, X $ W( 1, IW ), 1 ) X END IF X CALL DSCAL( I-1, TAU( I-1 ), W( 1, IW ), 1 ) X ALPHA = -HALF*TAU( I-1 )*DDOT( I-1, W( 1, IW ), 1, X $ A( 1, I ), 1 ) X CALL DAXPY( I-1, ALPHA, A( 1, I ), 1, W( 1, IW ), 1 ) X END IF X* X 10 CONTINUE X ELSE X* X* Reduce first NB columns of lower triangle X* X DO 20 I = 1, NB X* X* Update A(i:n,i) X* X CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, A( I, 1 ), X $ LDA, W( I, 1 ), LDW, ONE, A( I, I ), 1 ) X CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, W( I, 1 ), X $ LDW, A( I, 1 ), LDA, ONE, A( I, I ), 1 ) X IF( I.LT.N ) THEN X* X* Generate elementary reflector H(i) to annihilate X* A(i+2:n,i) X* X CALL DLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, X $ TAU( I ) ) X E( I ) = A( I+1, I ) X A( I+1, I ) = ONE X* X* Compute W(i+1:n,i) X* X CALL DSYMV( 'Lower', N-I, ONE, A( I+1, I+1 ), LDA, X $ A( I+1, I ), 1, ZERO, W( I+1, I ), 1 ) X CALL DGEMV( 'Transpose', N-I, I-1, ONE, W( I+1, 1 ), LDW, X $ A( I+1, I ), 1, ZERO, W( 1, I ), 1 ) X CALL DGEMV( 'No transpose', N-I, I-1, -ONE, A( I+1, 1 ), X $ LDA, W( 1, I ), 1, ONE, W( I+1, I ), 1 ) X CALL DGEMV( 'Transpose', N-I, I-1, ONE, A( I+1, 1 ), LDA, X $ A( I+1, I ), 1, ZERO, W( 1, I ), 1 ) X CALL DGEMV( 'No transpose', N-I, I-1, -ONE, W( I+1, 1 ), X $ LDW, W( 1, I ), 1, ONE, W( I+1, I ), 1 ) X CALL DSCAL( N-I, TAU( I ), W( I+1, I ), 1 ) X ALPHA = -HALF*TAU( I )*DDOT( N-I, W( I+1, I ), 1, X $ A( I+1, I ), 1 ) X CALL DAXPY( N-I, ALPHA, A( I+1, I ), 1, W( I+1, I ), 1 ) X END IF X* X 20 CONTINUE X END IF X* X RETURN X* X* End of DLATRD X* X END X SUBROUTINE DGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, X $ INFO ) X* X* -- LAPACK routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* March 31, 1993 X* X* .. Scalar Arguments .. X CHARACTER TRANS X INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS X* .. X* .. Array Arguments .. X INTEGER IPIV( * ) X DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ) X* .. X* X* Purpose X* ======= X* X* DGBTRS solves a system of linear equations X* A * X = B or A' * X = B X* with a general band matrix A using the LU factorization computed X* by DGBTRF. X* X* Arguments X* ========= X* X* TRANS (input) CHARACTER*1 X* Specifies the form of the system of equations. X* = 'N': A * X = B (No transpose) X* = 'T': A'* X = B (Transpose) X* = 'C': A'* X = B (Conjugate transpose = Transpose) X* X* N (input) INTEGER X* The order of the matrix A. N >= 0. X* X* KL (input) INTEGER X* The number of subdiagonals within the band of A. KL >= 0. X* X* KU (input) INTEGER X* The number of superdiagonals within the band of A. KU >= 0. X* X* NRHS (input) INTEGER X* The number of right hand sides, i.e., the number of columns X* of the matrix B. NRHS >= 0. X* X* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) X* Details of the LU factorization of the band matrix A, as X* computed by DGBTRF. U is stored as an upper triangular band X* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and X* the multipliers used during the factorization are stored in X* rows KL+KU+2 to 2*KL+KU+1. X* X* LDAB (input) INTEGER X* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. X* X* IPIV (input) INTEGER array, dimension (N) X* The pivot indices; for 1 <= i <= N, row i of the matrix was X* interchanged with row IPIV(i). X* X* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) X* On entry, the right hand side matrix B. X* On exit, the solution matrix X. X* X* LDB (input) INTEGER X* The leading dimension of the array B. LDB >= max(1,N). X* X* INFO (output) INTEGER X* = 0: successful exit X* < 0: if INFO = -i, the i-th argument had an illegal value X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ONE X PARAMETER ( ONE = 1.0D+0 ) X* .. X* .. Local Scalars .. X LOGICAL LNOTI, NOTRAN X INTEGER I, J, KD, L, LM X* .. X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. X* .. External Subroutines .. X EXTERNAL DGEMV, DGER, DSWAP, DTBSV, XERBLA X* .. X* .. Intrinsic Functions .. X INTRINSIC MAX, MIN X* .. X* .. Executable Statements .. X* X* Test the input parameters. X* X INFO = 0 X NOTRAN = LSAME( TRANS, 'N' ) X IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. X $ LSAME( TRANS, 'C' ) ) THEN X INFO = -1 X ELSE IF( N.LT.0 ) THEN X INFO = -2 X ELSE IF( KL.LT.0 ) THEN X INFO = -3 X ELSE IF( KU.LT.0 ) THEN X INFO = -4 X ELSE IF( NRHS.LT.0 ) THEN X INFO = -5 X ELSE IF( LDAB.LT.( 2*KL+KU+1 ) ) THEN X INFO = -7 X ELSE IF( LDB.LT.MAX( 1, N ) ) THEN X INFO = -10 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DGBTRS', -INFO ) X RETURN X END IF X* X* Quick return if possible X* X IF( N.EQ.0 .OR. NRHS.EQ.0 ) X $ RETURN X* X KD = KU + KL + 1 X LNOTI = KL.GT.0 X* X IF( NOTRAN ) THEN X* X* Solve A*X = B. X* X* Solve L*X = B, overwriting B with X. X* X* L is represented as a product of permutations and unit lower X* triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1), X* where each transformation L(i) is a rank-one modification of X* the identity matrix. X* X IF( LNOTI ) THEN X DO 10 J = 1, N - 1 X LM = MIN( KL, N-J ) X L = IPIV( J ) X IF( L.NE.J ) X $ CALL DSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB ) X CALL DGER( LM, NRHS, -ONE, AB( KD+1, J ), 1, B( J, 1 ), X $ LDB, B( J+1, 1 ), LDB ) X 10 CONTINUE X END IF X* X DO 20 I = 1, NRHS X* X* Solve U*X = B, overwriting B with X. X* X CALL DTBSV( 'Upper', 'No transpose', 'Non-unit', N, KL+KU, X $ AB, LDAB, B( 1, I ), 1 ) X 20 CONTINUE X* X ELSE X* X* Solve A'*X = B. X* X DO 30 I = 1, NRHS X* X* Solve U'*X = B, overwriting B with X. X* X CALL DTBSV( 'Upper', 'Transpose', 'Non-unit', N, KL+KU, AB, X $ LDAB, B( 1, I ), 1 ) X 30 CONTINUE X* X* Solve L'*X = B, overwriting B with X. X* X IF( LNOTI ) THEN X DO 40 J = N - 1, 1, -1 X LM = MIN( KL, N-J ) X CALL DGEMV( 'Transpose', LM, NRHS, -ONE, B( J+1, 1 ), X $ LDB, AB( KD+1, J ), 1, ONE, B( J, 1 ), LDB ) X L = IPIV( J ) X IF( L.NE.J ) X $ CALL DSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB ) X 40 CONTINUE X END IF X END IF X RETURN X* X* End of DGBTRS X* X END X SUBROUTINE DORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) X* X* -- LAPACK routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* September 30, 1994 X* X* .. Scalar Arguments .. X INTEGER INFO, K, LDA, LWORK, M, N X* .. X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( LWORK ) X* .. X* X* Purpose X* ======= X* X* DORGQL generates an M-by-N real matrix Q with orthonormal columns, X* which is defined as the last N columns of a product of K elementary X* reflectors of order M X* X* Q = H(k) . . . H(2) H(1) X* X* as returned by DGEQLF. X* X* Arguments X* ========= X* X* M (input) INTEGER X* The number of rows of the matrix Q. M >= 0. X* X* N (input) INTEGER X* The number of columns of the matrix Q. M >= N >= 0. X* X* K (input) INTEGER X* The number of elementary reflectors whose product defines the X* matrix Q. N >= K >= 0. X* X* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) X* On entry, the (n-k+i)-th column must contain the vector which X* defines the elementary reflector H(i), for i = 1,2,...,k, as X* returned by DGEQLF in the last k columns of its array X* argument A. X* On exit, the M-by-N matrix Q. X* X* LDA (input) INTEGER X* The first dimension of the array A. LDA >= max(1,M). X* X* TAU (input) DOUBLE PRECISION array, dimension (K) X* TAU(i) must contain the scalar factor of the elementary X* reflector H(i), as returned by DGEQLF. X* X* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) X* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. X* X* LWORK (input) INTEGER X* The dimension of the array WORK. LWORK >= max(1,N). X* For optimum performance LWORK >= N*NB, where NB is the X* optimal blocksize. X* X* INFO (output) INTEGER X* = 0: successful exit X* < 0: if INFO = -i, the i-th argument has an illegal value X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ZERO X PARAMETER ( ZERO = 0.0D+0 ) X* .. X* .. Local Scalars .. X INTEGER I, IB, IINFO, IWS, J, KK, L, LDWORK, NB, NBMIN, X $ NX X* .. X* .. External Subroutines .. X EXTERNAL DLARFB, DLARFT, DORG2L, XERBLA X* .. X* .. Intrinsic Functions .. X INTRINSIC MAX, MIN X* .. X* .. External Functions .. X INTEGER ILAENV X EXTERNAL ILAENV X* .. X* .. Executable Statements .. X* X* Test the input arguments X* X INFO = 0 X IF( M.LT.0 ) THEN X INFO = -1 X ELSE IF( N.LT.0 .OR. N.GT.M ) THEN X INFO = -2 X ELSE IF( K.LT.0 .OR. K.GT.N ) THEN X INFO = -3 X ELSE IF( LDA.LT.MAX( 1, M ) ) THEN X INFO = -5 X ELSE IF( LWORK.LT.MAX( 1, N ) ) THEN X INFO = -8 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DORGQL', -INFO ) X RETURN X END IF X* X* Quick return if possible X* X IF( N.LE.0 ) THEN X WORK( 1 ) = 1 X RETURN X END IF X* X* Determine the block size. X* X NB = ILAENV( 1, 'DORGQL', ' ', M, N, K, -1 ) X NBMIN = 2 X NX = 0 X IWS = N X IF( NB.GT.1 .AND. NB.LT.K ) THEN X* X* Determine when to cross over from blocked to unblocked code. X* X NX = MAX( 0, ILAENV( 3, 'DORGQL', ' ', M, N, K, -1 ) ) X IF( NX.LT.K ) THEN X* X* Determine if workspace is large enough for blocked code. X* X LDWORK = N X IWS = LDWORK*NB X IF( LWORK.LT.IWS ) THEN X* X* Not enough workspace to use optimal NB: reduce NB and X* determine the minimum value of NB. X* X NB = LWORK / LDWORK X NBMIN = MAX( 2, ILAENV( 2, 'DORGQL', ' ', M, N, K, -1 ) ) X END IF X END IF X END IF X* X IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN X* X* Use blocked code after the first block. X* The last kk columns are handled by the block method. X* X KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB ) X* X* Set A(m-kk+1:m,1:n-kk) to zero. X* X DO 20 J = 1, N - KK X DO 10 I = M - KK + 1, M X A( I, J ) = ZERO X 10 CONTINUE X 20 CONTINUE X ELSE X KK = 0 X END IF X* X* Use unblocked code for the first or only block. X* X CALL DORG2L( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO ) X* X IF( KK.GT.0 ) THEN X* X* Use blocked code X* X DO 50 I = K - KK + 1, K, NB X IB = MIN( NB, K-I+1 ) X IF( N-K+I.GT.1 ) THEN X* X* Form the triangular factor of the block reflector X* H = H(i+ib-1) . . . H(i+1) H(i) X* X CALL DLARFT( 'Backward', 'Columnwise', M-K+I+IB-1, IB, X $ A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK ) X* X* Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left X* X CALL DLARFB( 'Left', 'No transpose', 'Backward', X $ 'Columnwise', M-K+I+IB-1, N-K+I-1, IB, X $ A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA, X $ WORK( IB+1 ), LDWORK ) X END IF X* X* Apply H to rows 1:m-k+i+ib-1 of current block X* X CALL DORG2L( M-K+I+IB-1, IB, IB, A( 1, N-K+I ), LDA, X $ TAU( I ), WORK, IINFO ) X* X* Set rows m-k+i+ib:m of current block to zero X* X DO 40 J = N - K + I, N - K + I + IB - 1 X DO 30 L = M - K + I + IB, M X A( L, J ) = ZERO X 30 CONTINUE X 40 CONTINUE X 50 CONTINUE X END IF X* X WORK( 1 ) = IWS X RETURN X* X* End of DORGQL X* X END X SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) X* X* -- LAPACK auxiliary routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* October 31, 1992 X* X* .. Scalar Arguments .. X CHARACTER UPLO X INTEGER LDA, M, N X DOUBLE PRECISION ALPHA, BETA X* .. X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ) X* .. X* X* Purpose X* ======= X* X* DLASET initializes an m-by-n matrix A to BETA on the diagonal and X* ALPHA on the offdiagonals. X* X* Arguments X* ========= X* X* UPLO (input) CHARACTER*1 X* Specifies the part of the matrix A to be set. X* = 'U': Upper triangular part is set; the strictly lower X* triangular part of A is not changed. X* = 'L': Lower triangular part is set; the strictly upper X* triangular part of A is not changed. X* Otherwise: All of the matrix A is set. X* X* M (input) INTEGER X* The number of rows of the matrix A. M >= 0. X* X* N (input) INTEGER X* The number of columns of the matrix A. N >= 0. X* X* ALPHA (input) DOUBLE PRECISION X* The constant to which the offdiagonal elements are to be set. X* X* BETA (input) DOUBLE PRECISION X* The constant to which the diagonal elements are to be set. X* X* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) X* On exit, the leading m-by-n submatrix of A is set as follows: X* X* if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n, X* if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n, X* otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j, X* X* and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n). X* X* LDA (input) INTEGER X* The leading dimension of the array A. LDA >= max(1,M). X* X* ===================================================================== X* X* .. Local Scalars .. X INTEGER I, J X* .. X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. X* .. Intrinsic Functions .. X INTRINSIC MIN X* .. X* .. Executable Statements .. X* X IF( LSAME( UPLO, 'U' ) ) THEN X* X* Set the strictly upper triangular or trapezoidal part of the X* array to ALPHA. X* X DO 20 J = 2, N X DO 10 I = 1, MIN( J-1, M ) X A( I, J ) = ALPHA X 10 CONTINUE X 20 CONTINUE X* X ELSE IF( LSAME( UPLO, 'L' ) ) THEN X* X* Set the strictly lower triangular or trapezoidal part of the X* array to ALPHA. X* X DO 40 J = 1, MIN( M, N ) X DO 30 I = J + 1, M X A( I, J ) = ALPHA X 30 CONTINUE X 40 CONTINUE X* X ELSE X* X* Set the leading m-by-n submatrix to ALPHA. X* X DO 60 J = 1, N X DO 50 I = 1, M X A( I, J ) = ALPHA X 50 CONTINUE X 60 CONTINUE X END IF X* X* Set the first min(M,N) diagonal elements to BETA. X* X DO 70 I = 1, MIN( M, N ) X A( I, I ) = BETA X 70 CONTINUE X* X RETURN X* X* End of DLASET X* X END X SUBROUTINE DSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO ) X* X* -- LAPACK routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* October 31, 1992 X* X* .. Scalar Arguments .. X CHARACTER UPLO X INTEGER INFO, LDA, N X* .. X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ) X* .. X* X* Purpose X* ======= X* X* DSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal X* form T by an orthogonal similarity transformation: Q' * A * Q = T. X* X* Arguments X* ========= X* X* UPLO (input) CHARACTER*1 X* Specifies whether the upper or lower triangular part of the X* symmetric matrix A is stored: X* = 'U': Upper triangular X* = 'L': Lower triangular X* X* N (input) INTEGER X* The order of the matrix A. N >= 0. X* X* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) X* On entry, the symmetric matrix A. If UPLO = 'U', the leading X* n-by-n upper triangular part of A contains the upper X* triangular part of the matrix A, and the strictly lower X* triangular part of A is not referenced. If UPLO = 'L', the X* leading n-by-n lower triangular part of A contains the lower X* triangular part of the matrix A, and the strictly upper X* triangular part of A is not referenced. X* On exit, if UPLO = 'U', the diagonal and first superdiagonal X* of A are overwritten by the corresponding elements of the X* tridiagonal matrix T, and the elements above the first X* superdiagonal, with the array TAU, represent the orthogonal X* matrix Q as a product of elementary reflectors; if UPLO X* = 'L', the diagonal and first subdiagonal of A are over- X* written by the corresponding elements of the tridiagonal X* matrix T, and the elements below the first subdiagonal, with X* the array TAU, represent the orthogonal matrix Q as a product X* of elementary reflectors. See Further Details. X* X* LDA (input) INTEGER X* The leading dimension of the array A. LDA >= max(1,N). X* X* D (output) DOUBLE PRECISION array, dimension (N) X* The diagonal elements of the tridiagonal matrix T: X* D(i) = A(i,i). X* X* E (output) DOUBLE PRECISION array, dimension (N-1) X* The off-diagonal elements of the tridiagonal matrix T: X* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. X* X* TAU (output) DOUBLE PRECISION array, dimension (N-1) X* The scalar factors of the elementary reflectors (see Further X* Details). X* X* INFO (output) INTEGER X* = 0: successful exit X* < 0: if INFO = -i, the i-th argument had an illegal value. X* X* Further Details X* =============== X* X* If UPLO = 'U', the matrix Q is represented as a product of elementary X* reflectors X* X* Q = H(n-1) . . . H(2) H(1). X* X* Each H(i) has the form X* X* H(i) = I - tau * v * v' X* X* where tau is a real scalar, and v is a real vector with X* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in X* A(1:i-1,i+1), and tau in TAU(i). X* X* If UPLO = 'L', the matrix Q is represented as a product of elementary X* reflectors X* X* Q = H(1) H(2) . . . H(n-1). X* X* Each H(i) has the form X* X* H(i) = I - tau * v * v' X* X* where tau is a real scalar, and v is a real vector with X* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), X* and tau in TAU(i). X* X* The contents of A on exit are illustrated by the following examples X* with n = 5: X* X* if UPLO = 'U': if UPLO = 'L': X* X* ( d e v2 v3 v4 ) ( d ) X* ( d e v3 v4 ) ( e d ) X* ( d e v4 ) ( v1 e d ) X* ( d e ) ( v1 v2 e d ) X* ( d ) ( v1 v2 v3 e d ) X* X* where d and e denote diagonal and off-diagonal elements of T, and vi X* denotes an element of the vector defining H(i). X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ONE, ZERO, HALF X PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0, X $ HALF = 1.0D0 / 2.0D0 ) X* .. X* .. Local Scalars .. X LOGICAL UPPER X INTEGER I X DOUBLE PRECISION ALPHA, TAUI X* .. X* .. External Subroutines .. X EXTERNAL DAXPY, DLARFG, DSYMV, DSYR2, XERBLA X* .. X* .. External Functions .. X LOGICAL LSAME X DOUBLE PRECISION DDOT X EXTERNAL LSAME, DDOT X* .. X* .. Intrinsic Functions .. X INTRINSIC MAX, MIN X* .. X* .. Executable Statements .. X* X* Test the input parameters X* X INFO = 0 X UPPER = LSAME( UPLO, 'U' ) X IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN X INFO = -1 X ELSE IF( N.LT.0 ) THEN X INFO = -2 X ELSE IF( LDA.LT.MAX( 1, N ) ) THEN X INFO = -4 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DSYTD2', -INFO ) X RETURN X END IF X* X* Quick return if possible X* X IF( N.LE.0 ) X $ RETURN X* X IF( UPPER ) THEN X* X* Reduce the upper triangle of A X* X DO 10 I = N - 1, 1, -1 X* X* Generate elementary reflector H(i) = I - tau * v * v' X* to annihilate A(1:i-1,i+1) X* X CALL DLARFG( I, A( I, I+1 ), A( 1, I+1 ), 1, TAUI ) X E( I ) = A( I, I+1 ) X* X IF( TAUI.NE.ZERO ) THEN X* X* Apply H(i) from both sides to A(1:i,1:i) X* X A( I, I+1 ) = ONE X* X* Compute x := tau * A * v storing x in TAU(1:i) X* X CALL DSYMV( UPLO, I, TAUI, A, LDA, A( 1, I+1 ), 1, ZERO, X $ TAU, 1 ) X* X* Compute w := x - 1/2 * tau * (x'*v) * v X* X ALPHA = -HALF*TAUI*DDOT( I, TAU, 1, A( 1, I+1 ), 1 ) X CALL DAXPY( I, ALPHA, A( 1, I+1 ), 1, TAU, 1 ) X* X* Apply the transformation as a rank-2 update: X* A := A - v * w' - w * v' X* X CALL DSYR2( UPLO, I, -ONE, A( 1, I+1 ), 1, TAU, 1, A, X $ LDA ) X* X A( I, I+1 ) = E( I ) X END IF X D( I+1 ) = A( I+1, I+1 ) X TAU( I ) = TAUI X 10 CONTINUE X D( 1 ) = A( 1, 1 ) X ELSE X* X* Reduce the lower triangle of A X* X DO 20 I = 1, N - 1 X* X* Generate elementary reflector H(i) = I - tau * v * v' X* to annihilate A(i+2:n,i) X* X CALL DLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, X $ TAUI ) X E( I ) = A( I+1, I ) X* X IF( TAUI.NE.ZERO ) THEN X* X* Apply H(i) from both sides to A(i+1:n,i+1:n) X* X A( I+1, I ) = ONE X* X* Compute x := tau * A * v storing y in TAU(i:n-1) X* X CALL DSYMV( UPLO, N-I, TAUI, A( I+1, I+1 ), LDA, X $ A( I+1, I ), 1, ZERO, TAU( I ), 1 ) X* X* Compute w := x - 1/2 * tau * (x'*v) * v X* X ALPHA = -HALF*TAUI*DDOT( N-I, TAU( I ), 1, A( I+1, I ), X $ 1 ) X CALL DAXPY( N-I, ALPHA, A( I+1, I ), 1, TAU( I ), 1 ) X* X* Apply the transformation as a rank-2 update: X* A := A - v * w' - w * v' X* X CALL DSYR2( UPLO, N-I, -ONE, A( I+1, I ), 1, TAU( I ), 1, X $ A( I+1, I+1 ), LDA ) X* X A( I+1, I ) = E( I ) X END IF X D( I ) = A( I, I ) X TAU( I ) = TAUI X 20 CONTINUE X D( N ) = A( N, N ) X END IF X* X RETURN X* X* End of DSYTD2 X* X END X SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) X* X* -- LAPACK routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* September 30, 1994 X* X* .. Scalar Arguments .. X INTEGER INFO, K, LDA, LWORK, M, N X* .. X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( LWORK ) X* .. X* X* Purpose X* ======= X* X* DORGQR generates an M-by-N real matrix Q with orthonormal columns, X* which is defined as the first N columns of a product of K elementary X* reflectors of order M X* X* Q = H(1) H(2) . . . H(k) X* X* as returned by DGEQRF. X* X* Arguments X* ========= X* X* M (input) INTEGER X* The number of rows of the matrix Q. M >= 0. X* X* N (input) INTEGER X* The number of columns of the matrix Q. M >= N >= 0. X* X* K (input) INTEGER X* The number of elementary reflectors whose product defines the X* matrix Q. N >= K >= 0. X* X* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) X* On entry, the i-th column must contain the vector which X* defines the elementary reflector H(i), for i = 1,2,...,k, as X* returned by DGEQRF in the first k columns of its array X* argument A. X* On exit, the M-by-N matrix Q. X* X* LDA (input) INTEGER X* The first dimension of the array A. LDA >= max(1,M). X* X* TAU (input) DOUBLE PRECISION array, dimension (K) X* TAU(i) must contain the scalar factor of the elementary X* reflector H(i), as returned by DGEQRF. X* X* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) X* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. X* X* LWORK (input) INTEGER X* The dimension of the array WORK. LWORK >= max(1,N). X* For optimum performance LWORK >= N*NB, where NB is the X* optimal blocksize. X* X* INFO (output) INTEGER X* = 0: successful exit X* < 0: if INFO = -i, the i-th argument has an illegal value X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ZERO X PARAMETER ( ZERO = 0.0D+0 ) X* .. X* .. Local Scalars .. X INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, NB, X $ NBMIN, NX X* .. X* .. External Subroutines .. X EXTERNAL DLARFB, DLARFT, DORG2R, XERBLA X* .. X* .. Intrinsic Functions .. X INTRINSIC MAX, MIN X* .. X* .. External Functions .. X INTEGER ILAENV X EXTERNAL ILAENV X* .. X* .. Executable Statements .. X* X* Test the input arguments X* X INFO = 0 X IF( M.LT.0 ) THEN X INFO = -1 X ELSE IF( N.LT.0 .OR. N.GT.M ) THEN X INFO = -2 X ELSE IF( K.LT.0 .OR. K.GT.N ) THEN X INFO = -3 X ELSE IF( LDA.LT.MAX( 1, M ) ) THEN X INFO = -5 X ELSE IF( LWORK.LT.MAX( 1, N ) ) THEN X INFO = -8 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DORGQR', -INFO ) X RETURN X END IF X* X* Quick return if possible X* X IF( N.LE.0 ) THEN X WORK( 1 ) = 1 X RETURN X END IF X* X* Determine the block size. X* X NB = ILAENV( 1, 'DORGQR', ' ', M, N, K, -1 ) X NBMIN = 2 X NX = 0 X IWS = N X IF( NB.GT.1 .AND. NB.LT.K ) THEN X* X* Determine when to cross over from blocked to unblocked code. X* X NX = MAX( 0, ILAENV( 3, 'DORGQR', ' ', M, N, K, -1 ) ) X IF( NX.LT.K ) THEN X* X* Determine if workspace is large enough for blocked code. X* X LDWORK = N X IWS = LDWORK*NB X IF( LWORK.LT.IWS ) THEN X* X* Not enough workspace to use optimal NB: reduce NB and X* determine the minimum value of NB. X* X NB = LWORK / LDWORK X NBMIN = MAX( 2, ILAENV( 2, 'DORGQR', ' ', M, N, K, -1 ) ) X END IF X END IF X END IF X* X IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN X* X* Use blocked code after the last block. X* The first kk columns are handled by the block method. X* X KI = ( ( K-NX-1 ) / NB )*NB X KK = MIN( K, KI+NB ) X* X* Set A(1:kk,kk+1:n) to zero. X* X DO 20 J = KK + 1, N X DO 10 I = 1, KK X A( I, J ) = ZERO X 10 CONTINUE X 20 CONTINUE X ELSE X KK = 0 X END IF X* X* Use unblocked code for the last or only block. X* X IF( KK.LT.N ) X $ CALL DORG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, X $ TAU( KK+1 ), WORK, IINFO ) X* X IF( KK.GT.0 ) THEN X* X* Use blocked code X* X DO 50 I = KI + 1, 1, -NB X IB = MIN( NB, K-I+1 ) X IF( I+IB.LE.N ) THEN X* X* Form the triangular factor of the block reflector X* H = H(i) H(i+1) . . . H(i+ib-1) X* X CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB, X $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) X* X* Apply H to A(i:m,i+ib:n) from the left X* X CALL DLARFB( 'Left', 'No transpose', 'Forward', X $ 'Columnwise', M-I+1, N-I-IB+1, IB, X $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), X $ LDA, WORK( IB+1 ), LDWORK ) X END IF X* X* Apply H to rows i:m of current block X* X CALL DORG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK, X $ IINFO ) X* X* Set rows 1:i-1 of current block to zero X* X DO 40 J = I, I + IB - 1 X DO 30 L = 1, I - 1 X A( L, J ) = ZERO X 30 CONTINUE X 40 CONTINUE X 50 CONTINUE X END IF X* X WORK( 1 ) = IWS X RETURN X* X* End of DORGQR X* X END X SUBROUTINE DGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO ) X* X* -- LAPACK routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* February 29, 1992 X* X* .. Scalar Arguments .. X INTEGER INFO, KL, KU, LDAB, M, N X* .. X* .. Array Arguments .. X INTEGER IPIV( * ) X DOUBLE PRECISION AB( LDAB, * ) X* .. X* X* Purpose X* ======= X* X* DGBTRF computes an LU factorization of a real m-by-n band matrix A X* using partial pivoting with row interchanges. X* X* This is the blocked version of the algorithm, calling Level 3 BLAS. X* X* Arguments X* ========= X* X* M (input) INTEGER X* The number of rows of the matrix A. M >= 0. X* X* N (input) INTEGER X* The number of columns of the matrix A. N >= 0. X* X* KL (input) INTEGER X* The number of subdiagonals within the band of A. KL >= 0. X* X* KU (input) INTEGER X* The number of superdiagonals within the band of A. KU >= 0. X* X* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) X* On entry, the matrix A in band storage, in rows KL+1 to X* 2*KL+KU+1; rows 1 to KL of the array need not be set. X* The j-th column of A is stored in the j-th column of the X* array AB as follows: X* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) X* X* On exit, details of the factorization: U is stored as an X* upper triangular band matrix with KL+KU superdiagonals in X* rows 1 to KL+KU+1, and the multipliers used during the X* factorization are stored in rows KL+KU+2 to 2*KL+KU+1. X* See below for further details. X* X* LDAB (input) INTEGER X* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. X* X* IPIV (output) INTEGER array, dimension (min(M,N)) X* The pivot indices; for 1 <= i <= min(M,N), row i of the X* matrix was interchanged with row IPIV(i). X* X* INFO (output) INTEGER X* = 0: successful exit X* < 0: if INFO = -i, the i-th argument had an illegal value X* > 0: if INFO = +i, U(i,i) is exactly zero. The factorization X* has been completed, but the factor U is exactly X* singular, and division by zero will occur if it is used X* to solve a system of equations. X* X* Further Details X* =============== X* X* The band storage scheme is illustrated by the following example, when X* M = N = 6, KL = 2, KU = 1: X* X* On entry: On exit: X* X* * * * + + + * * * u14 u25 u36 X* * * + + + + * * u13 u24 u35 u46 X* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 X* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 X* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * X* a31 a42 a53 a64 * * m31 m42 m53 m64 * * X* X* Array elements marked * are not used by the routine; elements marked X* + need not be set on entry, but are required by the routine to store X* elements of U because of fill-in resulting from the row interchanges. X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ONE, ZERO X PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) X INTEGER NBMAX, LDWORK X PARAMETER ( NBMAX = 64, LDWORK = NBMAX+1 ) X* .. X* .. Local Scalars .. X INTEGER I, I2, I3, II, IP, J, J2, J3, JB, JJ, JM, JP, X $ JU, K2, KM, KV, NB, NW X DOUBLE PRECISION TEMP X* .. X* .. Local Arrays .. X DOUBLE PRECISION WORK13( LDWORK, NBMAX ), X $ WORK31( LDWORK, NBMAX ) X* .. X* .. External Functions .. X INTEGER IDAMAX, ILAENV X EXTERNAL IDAMAX, ILAENV X* .. X* .. External Subroutines .. X EXTERNAL DCOPY, DGBTF2, DGEMM, DGER, DLASWP, DSCAL, X $ DSWAP, DTRSM, XERBLA X* .. X* .. Intrinsic Functions .. X INTRINSIC MAX, MIN X* .. X* .. Executable Statements .. X* X* KV is the number of superdiagonals in the factor U, allowing for X* fill-in X* X KV = KU + KL X* X* Test the input parameters. X* X INFO = 0 X IF( M.LT.0 ) THEN X INFO = -1 X ELSE IF( N.LT.0 ) THEN X INFO = -2 X ELSE IF( KL.LT.0 ) THEN X INFO = -3 X ELSE IF( KU.LT.0 ) THEN X INFO = -4 X ELSE IF( LDAB.LT.KL+KV+1 ) THEN X INFO = -6 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DGBTRF', -INFO ) X RETURN X END IF X* X* Quick return if possible X* X IF( M.EQ.0 .OR. N.EQ.0 ) X $ RETURN X* X* Determine the block size for this environment X* X NB = ILAENV( 1, 'DGBTRF', ' ', M, N, KL, KU ) X* X* The block size must not exceed the limit set by the size of the X* local arrays WORK13 and WORK31. X* X NB = MIN( NB, NBMAX ) X* X IF( NB.LE.1 .OR. NB.GT.KL ) THEN X* X* Use unblocked code X* X CALL DGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) X ELSE X* X* Use blocked code X* X* Zero the superdiagonal elements of the work array WORK13 X* X DO 20 J = 1, NB X DO 10 I = 1, J - 1 X WORK13( I, J ) = ZERO X 10 CONTINUE X 20 CONTINUE X* X* Zero the subdiagonal elements of the work array WORK31 X* X DO 40 J = 1, NB X DO 30 I = J + 1, NB X WORK31( I, J ) = ZERO X 30 CONTINUE X 40 CONTINUE X* X* Gaussian elimination with partial pivoting X* X* Set fill-in elements in columns KU+2 to KV to zero X* X DO 60 J = KU + 2, MIN( KV, N ) X DO 50 I = KV - J + 2, KL X AB( I, J ) = ZERO X 50 CONTINUE X 60 CONTINUE X* X* JU is the index of the last column affected by the current X* stage of the factorization X* X JU = 1 X* X DO 180 J = 1, MIN( M, N ), NB X JB = MIN( NB, MIN( M, N )-J+1 ) X* X* The active part of the matrix is partitioned X* X* A11 A12 A13 X* A21 A22 A23 X* A31 A32 A33 X* X* Here A11, A21 and A31 denote the current block of JB columns X* which is about to be factorized. The number of rows in the X* partitioning are JB, I2, I3 respectively, and the numbers X* of columns are JB, J2, J3. The superdiagonal elements of A13 X* and the subdiagonal elements of A31 lie outside the band. X* X I2 = MIN( KL-JB, M-J-JB+1 ) X I3 = MIN( JB, M-J-KL+1 ) X* X* J2 and J3 are computed after JU has been updated. X* X* Factorize the current block of JB columns X* X DO 80 JJ = J, J + JB - 1 X* X* Set fill-in elements in column JJ+KV to zero X* X IF( JJ+KV.LE.N ) THEN X DO 70 I = 1, KL X AB( I, JJ+KV ) = ZERO X 70 CONTINUE X END IF X* X* Find pivot and test for singularity. KM is the number of X* subdiagonal elements in the current column. X* X KM = MIN( KL, M-JJ ) X JP = IDAMAX( KM+1, AB( KV+1, JJ ), 1 ) X IPIV( JJ ) = JP + JJ - J X IF( AB( KV+JP, JJ ).NE.ZERO ) THEN X JU = MAX( JU, MIN( JJ+KU+JP-1, N ) ) X IF( JP.NE.1 ) THEN X* X* Apply interchange to columns J to J+JB-1 X* X IF( JP+JJ-1.LT.J+KL ) THEN X* X CALL DSWAP( JB, AB( KV+1+JJ-J, J ), LDAB-1, X $ AB( KV+JP+JJ-J, J ), LDAB-1 ) X ELSE X* X* The interchange affects columns J to JJ-1 of A31 X* which are stored in the work array WORK31 X* X CALL DSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1, X $ WORK31( JP+JJ-J-KL, 1 ), LDWORK ) X CALL DSWAP( J+JB-JJ, AB( KV+1, JJ ), LDAB-1, X $ AB( KV+JP, JJ ), LDAB-1 ) X END IF X END IF X* X* Compute multipliers X* X CALL DSCAL( KM, ONE / AB( KV+1, JJ ), AB( KV+2, JJ ), X $ 1 ) X* X* Update trailing submatrix within the band and within X* the current block. JM is the index of the last column X* which needs to be updated. X* X JM = MIN( JU, J+JB-1 ) X IF( JM.GT.JJ ) X $ CALL DGER( KM, JM-JJ, -ONE, AB( KV+2, JJ ), 1, X $ AB( KV, JJ+1 ), LDAB-1, X $ AB( KV+1, JJ+1 ), LDAB-1 ) X ELSE X* X* If pivot is zero, set INFO to the index of the pivot X* unless a zero pivot has already been found. X* X IF( INFO.EQ.0 ) X $ INFO = JJ X END IF X* X* Copy current column of A31 into the work array WORK31 X* X NW = MIN( JJ-J+1, I3 ) X IF( NW.GT.0 ) X $ CALL DCOPY( NW, AB( KV+KL+1-JJ+J, JJ ), 1, X $ WORK31( 1, JJ-J+1 ), 1 ) X 80 CONTINUE X IF( J+JB.LE.N ) THEN X* X* Apply the row interchanges to the other blocks. X* X J2 = MIN( JU-J+1, KV ) - JB X J3 = MAX( 0, JU-J-KV+1 ) X* X* Use DLASWP to apply the row interchanges to A12, A22, and X* A32. X* X CALL DLASWP( J2, AB( KV+1-JB, J+JB ), LDAB-1, 1, JB, X $ IPIV( J ), 1 ) X* X* Adjust the pivot indices. X* X DO 90 I = J, J + JB - 1 X IPIV( I ) = IPIV( I ) + J - 1 X 90 CONTINUE X* X* Apply the row interchanges to A13, A23, and A33 X* columnwise. X* X K2 = J - 1 + JB + J2 X DO 110 I = 1, J3 X JJ = K2 + I X DO 100 II = J + I - 1, J + JB - 1 X IP = IPIV( II ) X IF( IP.NE.II ) THEN X TEMP = AB( KV+1+II-JJ, JJ ) X AB( KV+1+II-JJ, JJ ) = AB( KV+1+IP-JJ, JJ ) X AB( KV+1+IP-JJ, JJ ) = TEMP X END IF X 100 CONTINUE X 110 CONTINUE X* X* Update the relevant part of the trailing submatrix X* X IF( J2.GT.0 ) THEN X* X* Update A12 X* X CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', X $ JB, J2, ONE, AB( KV+1, J ), LDAB-1, X $ AB( KV+1-JB, J+JB ), LDAB-1 ) X* X IF( I2.GT.0 ) THEN X* X* Update A22 X* X CALL DGEMM( 'No transpose', 'No transpose', I2, J2, X $ JB, -ONE, AB( KV+1+JB, J ), LDAB-1, X $ AB( KV+1-JB, J+JB ), LDAB-1, ONE, X $ AB( KV+1, J+JB ), LDAB-1 ) X END IF X* X IF( I3.GT.0 ) THEN X* X* Update A32 X* X CALL DGEMM( 'No transpose', 'No transpose', I3, J2, X $ JB, -ONE, WORK31, LDWORK, X $ AB( KV+1-JB, J+JB ), LDAB-1, ONE, X $ AB( KV+KL+1-JB, J+JB ), LDAB-1 ) X END IF X END IF X* X IF( J3.GT.0 ) THEN X* X* Copy the lower triangle of A13 into the work array X* WORK13 X* X DO 130 JJ = 1, J3 X DO 120 II = JJ, JB X WORK13( II, JJ ) = AB( II-JJ+1, JJ+J+KV-1 ) X 120 CONTINUE X 130 CONTINUE X* X* Update A13 in the work array X* X CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', X $ JB, J3, ONE, AB( KV+1, J ), LDAB-1, X $ WORK13, LDWORK ) X* X IF( I2.GT.0 ) THEN X* X* Update A23 X* X CALL DGEMM( 'No transpose', 'No transpose', I2, J3, X $ JB, -ONE, AB( KV+1+JB, J ), LDAB-1, X $ WORK13, LDWORK, ONE, AB( 1+JB, J+KV ), X $ LDAB-1 ) X END IF X* X IF( I3.GT.0 ) THEN X* X* Update A33 X* X CALL DGEMM( 'No transpose', 'No transpose', I3, J3, X $ JB, -ONE, WORK31, LDWORK, WORK13, X $ LDWORK, ONE, AB( 1+KL, J+KV ), LDAB-1 ) X END IF X* X* Copy the lower triangle of A13 back into place X* X DO 150 JJ = 1, J3 X DO 140 II = JJ, JB X AB( II-JJ+1, JJ+J+KV-1 ) = WORK13( II, JJ ) X 140 CONTINUE X 150 CONTINUE X END IF X ELSE X* X* Adjust the pivot indices. X* X DO 160 I = J, J + JB - 1 X IPIV( I ) = IPIV( I ) + J - 1 X 160 CONTINUE X END IF X* X* Partially undo the interchanges in the current block to X* restore the upper triangular form of A31 and copy the upper X* triangle of A31 back into place X* X DO 170 JJ = J + JB - 1, J, -1 X JP = IPIV( JJ ) - JJ + 1 X IF( JP.NE.1 ) THEN X* X* Apply interchange to columns J to JJ-1 X* X IF( JP+JJ-1.LT.J+KL ) THEN X* X* The interchange does not affect A31 X* X CALL DSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1, X $ AB( KV+JP+JJ-J, J ), LDAB-1 ) X ELSE X* X* The interchange does affect A31 X* X CALL DSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1, X $ WORK31( JP+JJ-J-KL, 1 ), LDWORK ) X END IF X END IF X* X* Copy the current column of A31 back into place X* X NW = MIN( I3, JJ-J+1 ) X IF( NW.GT.0 ) X $ CALL DCOPY( NW, WORK31( 1, JJ-J+1 ), 1, X $ AB( KV+KL+1-JJ+J, JJ ), 1 ) X 170 CONTINUE X 180 CONTINUE X END IF X* X RETURN X* X* End of DGBTRF X* X END X* X SUBROUTINE DGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) X* X* -- LAPACK routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* February 29, 1992 X* X* .. Scalar Arguments .. X INTEGER INFO, KL, KU, LDAB, M, N X* .. X* .. Array Arguments .. X INTEGER IPIV( * ) X DOUBLE PRECISION AB( LDAB, * ) X* .. X* X* Purpose X* ======= X* X* DGBTF2 computes an LU factorization of a real m-by-n band matrix A X* using partial pivoting with row interchanges. X* X* This is the unblocked version of the algorithm, calling Level 2 BLAS. X* X* Arguments X* ========= X* X* M (input) INTEGER X* The number of rows of the matrix A. M >= 0. X* X* N (input) INTEGER X* The number of columns of the matrix A. N >= 0. X* X* KL (input) INTEGER X* The number of subdiagonals within the band of A. KL >= 0. X* X* KU (input) INTEGER X* The number of superdiagonals within the band of A. KU >= 0. X* X* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) X* On entry, the matrix A in band storage, in rows KL+1 to X* 2*KL+KU+1; rows 1 to KL of the array need not be set. X* The j-th column of A is stored in the j-th column of the X* array AB as follows: X* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) X* X* On exit, details of the factorization: U is stored as an X* upper triangular band matrix with KL+KU superdiagonals in X* rows 1 to KL+KU+1, and the multipliers used during the X* factorization are stored in rows KL+KU+2 to 2*KL+KU+1. X* See below for further details. X* X* LDAB (input) INTEGER X* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. X* X* IPIV (output) INTEGER array, dimension (min(M,N)) X* The pivot indices; for 1 <= i <= min(M,N), row i of the X* matrix was interchanged with row IPIV(i). X* X* INFO (output) INTEGER X* = 0: successful exit X* < 0: if INFO = -i, the i-th argument had an illegal value X* > 0: if INFO = +i, U(i,i) is exactly zero. The factorization X* has been completed, but the factor U is exactly X* singular, and division by zero will occur if it is used X* to solve a system of equations. X* X* Further Details X* =============== X* X* The band storage scheme is illustrated by the following example, when X* M = N = 6, KL = 2, KU = 1: X* X* On entry: On exit: X* X* * * * + + + * * * u14 u25 u36 X* * * + + + + * * u13 u24 u35 u46 X* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 X* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 X* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * X* a31 a42 a53 a64 * * m31 m42 m53 m64 * * X* X* Array elements marked * are not used by the routine; elements marked X* + need not be set on entry, but are required by the routine to store X* elements of U, because of fill-in resulting from the row X* interchanges. X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ONE, ZERO X PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) X* .. X* .. Local Scalars .. X INTEGER I, J, JP, JU, KM, KV X* .. X* .. External Functions .. X INTEGER IDAMAX X EXTERNAL IDAMAX X* .. X* .. External Subroutines .. X EXTERNAL DGER, DSCAL, DSWAP, XERBLA X* .. X* .. Intrinsic Functions .. X INTRINSIC MAX, MIN X* .. X* .. Executable Statements .. X* X* KV is the number of superdiagonals in the factor U, allowing for X* fill-in. X* X KV = KU + KL X* X* Test the input parameters. X* X INFO = 0 X IF( M.LT.0 ) THEN X INFO = -1 X ELSE IF( N.LT.0 ) THEN X INFO = -2 X ELSE IF( KL.LT.0 ) THEN X INFO = -3 X ELSE IF( KU.LT.0 ) THEN X INFO = -4 X ELSE IF( LDAB.LT.KL+KV+1 ) THEN X INFO = -6 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DGBTF2', -INFO ) X RETURN X END IF X* X* Quick return if possible X* X IF( M.EQ.0 .OR. N.EQ.0 ) X $ RETURN X* X* Gaussian elimination with partial pivoting X* X* Set fill-in elements in columns KU+2 to KV to zero. X* X DO 20 J = KU + 2, MIN( KV, N ) X DO 10 I = KV - J + 2, KL X AB( I, J ) = ZERO X 10 CONTINUE X 20 CONTINUE X* X* JU is the index of the last column affected by the current stage X* of the factorization. X* X JU = 1 X* X DO 40 J = 1, MIN( M, N ) X* X* Set fill-in elements in column J+KV to zero. X* X IF( J+KV.LE.N ) THEN X DO 30 I = 1, KL X AB( I, J+KV ) = ZERO X 30 CONTINUE X END IF X* X* Find pivot and test for singularity. KM is the number of X* subdiagonal elements in the current column. X* X KM = MIN( KL, M-J ) X JP = IDAMAX( KM+1, AB( KV+1, J ), 1 ) X IPIV( J ) = JP + J - 1 X IF( AB( KV+JP, J ).NE.ZERO ) THEN X JU = MAX( JU, MIN( J+KU+JP-1, N ) ) X* X* Apply interchange to columns J to JU. X* X IF( JP.NE.1 ) X $ CALL DSWAP( JU-J+1, AB( KV+JP, J ), LDAB-1, X $ AB( KV+1, J ), LDAB-1 ) X* X IF( KM.GT.0 ) THEN X* X* Compute multipliers. X* X CALL DSCAL( KM, ONE / AB( KV+1, J ), AB( KV+2, J ), 1 ) X* X* Update trailing submatrix within the band. X* X IF( JU.GT.J ) X $ CALL DGER( KM, JU-J, -ONE, AB( KV+2, J ), 1, X $ AB( KV, J+1 ), LDAB-1, AB( KV+1, J+1 ), X $ LDAB-1 ) X END IF X ELSE X* X* If pivot is zero, set INFO to the index of the pivot X* unless a zero pivot has already been found. X* X IF( INFO.EQ.0 ) X $ INFO = J X END IF X 40 CONTINUE X RETURN X* X* End of DGBTF2 X* X END X SUBROUTINE DLARUV( ISEED, N, X ) X* X* -- LAPACK auxiliary routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* October 31, 1992 X* X* .. Scalar Arguments .. X INTEGER N X* .. X* .. Array Arguments .. X INTEGER ISEED( 4 ) X DOUBLE PRECISION X( N ) X* .. X* X* Purpose X* ======= X* X* DLARUV returns a vector of n random real numbers from a uniform (0,1) X* distribution (n <= 128). X* X* This is an auxiliary routine called by DLARNV and ZLARNV. X* X* Arguments X* ========= X* X* ISEED (input/output) INTEGER array, dimension (4) X* On entry, the seed of the random number generator; the array X* elements must be between 0 and 4095, and ISEED(4) must be X* odd. X* On exit, the seed is updated. X* X* N (input) INTEGER X* The number of random numbers to be generated. N <= 128. X* X* X (output) DOUBLE PRECISION array, dimension (N) X* The generated random numbers. X* X* Further Details X* =============== X* X* This routine uses a multiplicative congruential method with modulus X* 2**48 and multiplier 33952834046453 (see G.S.Fishman, X* 'Multiplicative congruential random number generators with modulus X* 2**b: an exhaustive analysis for b = 32 and a partial analysis for X* b = 48', Math. Comp. 189, pp 331-344, 1990). X* X* 48-bit integers are stored in 4 integer array elements with 12 bits X* per element. Hence the routine is portable across machines with X* integers of 32 bits or more. X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ONE X PARAMETER ( ONE = 1.0D0 ) X INTEGER LV, IPW2 X DOUBLE PRECISION R X PARAMETER ( LV = 128, IPW2 = 4096, R = ONE / IPW2 ) X* .. X* .. Local Scalars .. X INTEGER I, I1, I2, I3, I4, IT1, IT2, IT3, IT4, J X* .. X* .. Local Arrays .. X INTEGER MM( LV, 4 ) X* .. X* .. Intrinsic Functions .. X INTRINSIC DBLE, MIN, MOD X* .. X* .. Data statements .. X DATA ( MM( 1, J ), J = 1, 4 ) / 494, 322, 2508, X $ 2549 / X DATA ( MM( 2, J ), J = 1, 4 ) / 2637, 789, 3754, X $ 1145 / X DATA ( MM( 3, J ), J = 1, 4 ) / 255, 1440, 1766, X $ 2253 / X DATA ( MM( 4, J ), J = 1, 4 ) / 2008, 752, 3572, X $ 305 / X DATA ( MM( 5, J ), J = 1, 4 ) / 1253, 2859, 2893, X $ 3301 / X DATA ( MM( 6, J ), J = 1, 4 ) / 3344, 123, 307, X $ 1065 / X DATA ( MM( 7, J ), J = 1, 4 ) / 4084, 1848, 1297, X $ 3133 / X DATA ( MM( 8, J ), J = 1, 4 ) / 1739, 643, 3966, X $ 2913 / X DATA ( MM( 9, J ), J = 1, 4 ) / 3143, 2405, 758, X $ 3285 / X DATA ( MM( 10, J ), J = 1, 4 ) / 3468, 2638, 2598, X $ 1241 / X DATA ( MM( 11, J ), J = 1, 4 ) / 688, 2344, 3406, X $ 1197 / X DATA ( MM( 12, J ), J = 1, 4 ) / 1657, 46, 2922, X $ 3729 / X DATA ( MM( 13, J ), J = 1, 4 ) / 1238, 3814, 1038, X $ 2501 / X DATA ( MM( 14, J ), J = 1, 4 ) / 3166, 913, 2934, X $ 1673 / X DATA ( MM( 15, J ), J = 1, 4 ) / 1292, 3649, 2091, X $ 541 / X DATA ( MM( 16, J ), J = 1, 4 ) / 3422, 339, 2451, X $ 2753 / X DATA ( MM( 17, J ), J = 1, 4 ) / 1270, 3808, 1580, X $ 949 / X DATA ( MM( 18, J ), J = 1, 4 ) / 2016, 822, 1958, X $ 2361 / X DATA ( MM( 19, J ), J = 1, 4 ) / 154, 2832, 2055, X $ 1165 / X DATA ( MM( 20, J ), J = 1, 4 ) / 2862, 3078, 1507, X $ 4081 / X DATA ( MM( 21, J ), J = 1, 4 ) / 697, 3633, 1078, X $ 2725 / X DATA ( MM( 22, J ), J = 1, 4 ) / 1706, 2970, 3273, X $ 3305 / X DATA ( MM( 23, J ), J = 1, 4 ) / 491, 637, 17, X $ 3069 / X DATA ( MM( 24, J ), J = 1, 4 ) / 931, 2249, 854, X $ 3617 / X DATA ( MM( 25, J ), J = 1, 4 ) / 1444, 2081, 2916, X $ 3733 / X DATA ( MM( 26, J ), J = 1, 4 ) / 444, 4019, 3971, X $ 409 / X DATA ( MM( 27, J ), J = 1, 4 ) / 3577, 1478, 2889, X $ 2157 / X DATA ( MM( 28, J ), J = 1, 4 ) / 3944, 242, 3831, X $ 1361 / X DATA ( MM( 29, J ), J = 1, 4 ) / 2184, 481, 2621, X $ 3973 / X DATA ( MM( 30, J ), J = 1, 4 ) / 1661, 2075, 1541, X $ 1865 / X DATA ( MM( 31, J ), J = 1, 4 ) / 3482, 4058, 893, X $ 2525 / X DATA ( MM( 32, J ), J = 1, 4 ) / 657, 622, 736, X $ 1409 / X DATA ( MM( 33, J ), J = 1, 4 ) / 3023, 3376, 3992, X $ 3445 / X DATA ( MM( 34, J ), J = 1, 4 ) / 3618, 812, 787, X $ 3577 / X DATA ( MM( 35, J ), J = 1, 4 ) / 1267, 234, 2125, X $ 77 / X DATA ( MM( 36, J ), J = 1, 4 ) / 1828, 641, 2364, X $ 3761 / X DATA ( MM( 37, J ), J = 1, 4 ) / 164, 4005, 2460, X $ 2149 / X DATA ( MM( 38, J ), J = 1, 4 ) / 3798, 1122, 257, X $ 1449 / X DATA ( MM( 39, J ), J = 1, 4 ) / 3087, 3135, 1574, X $ 3005 / X DATA ( MM( 40, J ), J = 1, 4 ) / 2400, 2640, 3912, X $ 225 / X DATA ( MM( 41, J ), J = 1, 4 ) / 2870, 2302, 1216, X $ 85 / X DATA ( MM( 42, J ), J = 1, 4 ) / 3876, 40, 3248, X $ 3673 / X DATA ( MM( 43, J ), J = 1, 4 ) / 1905, 1832, 3401, X $ 3117 / X DATA ( MM( 44, J ), J = 1, 4 ) / 1593, 2247, 2124, X $ 3089 / X DATA ( MM( 45, J ), J = 1, 4 ) / 1797, 2034, 2762, X $ 1349 / X DATA ( MM( 46, J ), J = 1, 4 ) / 1234, 2637, 149, X $ 2057 / X DATA ( MM( 47, J ), J = 1, 4 ) / 3460, 1287, 2245, X $ 413 / X DATA ( MM( 48, J ), J = 1, 4 ) / 328, 1691, 166, X $ 65 / X DATA ( MM( 49, J ), J = 1, 4 ) / 2861, 496, 466, X $ 1845 / X DATA ( MM( 50, J ), J = 1, 4 ) / 1950, 1597, 4018, X $ 697 / X DATA ( MM( 51, J ), J = 1, 4 ) / 617, 2394, 1399, X $ 3085 / X DATA ( MM( 52, J ), J = 1, 4 ) / 2070, 2584, 190, X $ 3441 / X DATA ( MM( 53, J ), J = 1, 4 ) / 3331, 1843, 2879, X $ 1573 / X DATA ( MM( 54, J ), J = 1, 4 ) / 769, 336, 153, X $ 3689 / X DATA ( MM( 55, J ), J = 1, 4 ) / 1558, 1472, 2320, X $ 2941 / X DATA ( MM( 56, J ), J = 1, 4 ) / 2412, 2407, 18, X $ 929 / X DATA ( MM( 57, J ), J = 1, 4 ) / 2800, 433, 712, X $ 533 / X DATA ( MM( 58, J ), J = 1, 4 ) / 189, 2096, 2159, X $ 2841 / X DATA ( MM( 59, J ), J = 1, 4 ) / 287, 1761, 2318, X $ 4077 / X DATA ( MM( 60, J ), J = 1, 4 ) / 2045, 2810, 2091, X $ 721 / X DATA ( MM( 61, J ), J = 1, 4 ) / 1227, 566, 3443, X $ 2821 / X DATA ( MM( 62, J ), J = 1, 4 ) / 2838, 442, 1510, X $ 2249 / X DATA ( MM( 63, J ), J = 1, 4 ) / 209, 41, 449, X $ 2397 / X DATA ( MM( 64, J ), J = 1, 4 ) / 2770, 1238, 1956, X $ 2817 / X DATA ( MM( 65, J ), J = 1, 4 ) / 3654, 1086, 2201, X $ 245 / X DATA ( MM( 66, J ), J = 1, 4 ) / 3993, 603, 3137, X $ 1913 / X DATA ( MM( 67, J ), J = 1, 4 ) / 192, 840, 3399, X $ 1997 / X DATA ( MM( 68, J ), J = 1, 4 ) / 2253, 3168, 1321, X $ 3121 / X DATA ( MM( 69, J ), J = 1, 4 ) / 3491, 1499, 2271, X $ 997 / X DATA ( MM( 70, J ), J = 1, 4 ) / 2889, 1084, 3667, X $ 1833 / X DATA ( MM( 71, J ), J = 1, 4 ) / 2857, 3438, 2703, X $ 2877 / X DATA ( MM( 72, J ), J = 1, 4 ) / 2094, 2408, 629, X $ 1633 / X DATA ( MM( 73, J ), J = 1, 4 ) / 1818, 1589, 2365, X $ 981 / X DATA ( MM( 74, J ), J = 1, 4 ) / 688, 2391, 2431, X $ 2009 / X DATA ( MM( 75, J ), J = 1, 4 ) / 1407, 288, 1113, X $ 941 / X DATA ( MM( 76, J ), J = 1, 4 ) / 634, 26, 3922, X $ 2449 / X DATA ( MM( 77, J ), J = 1, 4 ) / 3231, 512, 2554, X $ 197 / X DATA ( MM( 78, J ), J = 1, 4 ) / 815, 1456, 184, X $ 2441 / X DATA ( MM( 79, J ), J = 1, 4 ) / 3524, 171, 2099, X $ 285 / X DATA ( MM( 80, J ), J = 1, 4 ) / 1914, 1677, 3228, X $ 1473 / X DATA ( MM( 81, J ), J = 1, 4 ) / 516, 2657, 4012, X $ 2741 / X DATA ( MM( 82, J ), J = 1, 4 ) / 164, 2270, 1921, X $ 3129 / X DATA ( MM( 83, J ), J = 1, 4 ) / 303, 2587, 3452, X $ 909 / X DATA ( MM( 84, J ), J = 1, 4 ) / 2144, 2961, 3901, X $ 2801 / X DATA ( MM( 85, J ), J = 1, 4 ) / 3480, 1970, 572, X $ 421 / X DATA ( MM( 86, J ), J = 1, 4 ) / 119, 1817, 3309, X $ 4073 / X DATA ( MM( 87, J ), J = 1, 4 ) / 3357, 676, 3171, X $ 2813 / X DATA ( MM( 88, J ), J = 1, 4 ) / 837, 1410, 817, X $ 2337 / X DATA ( MM( 89, J ), J = 1, 4 ) / 2826, 3723, 3039, X $ 1429 / X DATA ( MM( 90, J ), J = 1, 4 ) / 2332, 2803, 1696, X $ 1177 / X DATA ( MM( 91, J ), J = 1, 4 ) / 2089, 3185, 1256, X $ 1901 / X DATA ( MM( 92, J ), J = 1, 4 ) / 3780, 184, 3715, X $ 81 / X DATA ( MM( 93, J ), J = 1, 4 ) / 1700, 663, 2077, X $ 1669 / X DATA ( MM( 94, J ), J = 1, 4 ) / 3712, 499, 3019, X $ 2633 / X DATA ( MM( 95, J ), J = 1, 4 ) / 150, 3784, 1497, X $ 2269 / X DATA ( MM( 96, J ), J = 1, 4 ) / 2000, 1631, 1101, X $ 129 / X DATA ( MM( 97, J ), J = 1, 4 ) / 3375, 1925, 717, X $ 1141 / X DATA ( MM( 98, J ), J = 1, 4 ) / 1621, 3912, 51, X $ 249 / X DATA ( MM( 99, J ), J = 1, 4 ) / 3090, 1398, 981, X $ 3917 / X DATA ( MM( 100, J ), J = 1, 4 ) / 3765, 1349, 1978, X $ 2481 / X DATA ( MM( 101, J ), J = 1, 4 ) / 1149, 1441, 1813, X $ 3941 / X DATA ( MM( 102, J ), J = 1, 4 ) / 3146, 2224, 3881, X $ 2217 / X DATA ( MM( 103, J ), J = 1, 4 ) / 33, 2411, 76, X $ 2749 / X DATA ( MM( 104, J ), J = 1, 4 ) / 3082, 1907, 3846, X $ 3041 / X DATA ( MM( 105, J ), J = 1, 4 ) / 2741, 3192, 3694, X $ 1877 / X DATA ( MM( 106, J ), J = 1, 4 ) / 359, 2786, 1682, X $ 345 / X DATA ( MM( 107, J ), J = 1, 4 ) / 3316, 382, 124, X $ 2861 / X DATA ( MM( 108, J ), J = 1, 4 ) / 1749, 37, 1660, X $ 1809 / X DATA ( MM( 109, J ), J = 1, 4 ) / 185, 759, 3997, X $ 3141 / X DATA ( MM( 110, J ), J = 1, 4 ) / 2784, 2948, 479, X $ 2825 / X DATA ( MM( 111, J ), J = 1, 4 ) / 2202, 1862, 1141, X $ 157 / X DATA ( MM( 112, J ), J = 1, 4 ) / 2199, 3802, 886, X $ 2881 / X DATA ( MM( 113, J ), J = 1, 4 ) / 1364, 2423, 3514, X $ 3637 / X DATA ( MM( 114, J ), J = 1, 4 ) / 1244, 2051, 1301, X $ 1465 / X DATA ( MM( 115, J ), J = 1, 4 ) / 2020, 2295, 3604, X $ 2829 / X DATA ( MM( 116, J ), J = 1, 4 ) / 3160, 1332, 1888, X $ 2161 / X DATA ( MM( 117, J ), J = 1, 4 ) / 2785, 1832, 1836, X $ 3365 / X DATA ( MM( 118, J ), J = 1, 4 ) / 2772, 2405, 1990, X $ 361 / X DATA ( MM( 119, J ), J = 1, 4 ) / 1217, 3638, 2058, X $ 2685 / X DATA ( MM( 120, J ), J = 1, 4 ) / 1822, 3661, 692, X $ 3745 / X DATA ( MM( 121, J ), J = 1, 4 ) / 1245, 327, 1194, X $ 2325 / X DATA ( MM( 122, J ), J = 1, 4 ) / 2252, 3660, 20, X $ 3609 / X DATA ( MM( 123, J ), J = 1, 4 ) / 3904, 716, 3285, X $ 3821 / X DATA ( MM( 124, J ), J = 1, 4 ) / 2774, 1842, 2046, X $ 3537 / X DATA ( MM( 125, J ), J = 1, 4 ) / 997, 3987, 2107, X $ 517 / X DATA ( MM( 126, J ), J = 1, 4 ) / 2573, 1368, 3508, X $ 3017 / X DATA ( MM( 127, J ), J = 1, 4 ) / 1148, 1848, 3525, X $ 2141 / X DATA ( MM( 128, J ), J = 1, 4 ) / 545, 2366, 3801, X $ 1537 / X* .. X* .. Executable Statements .. X* X I1 = ISEED( 1 ) X I2 = ISEED( 2 ) X I3 = ISEED( 3 ) X I4 = ISEED( 4 ) X* X DO 10 I = 1, MIN( N, LV ) X* X* Multiply the seed by i-th power of the multiplier modulo 2**48 X* X IT4 = I4*MM( I, 4 ) X IT3 = IT4 / IPW2 X IT4 = IT4 - IPW2*IT3 X IT3 = IT3 + I3*MM( I, 4 ) + I4*MM( I, 3 ) X IT2 = IT3 / IPW2 X IT3 = IT3 - IPW2*IT2 X IT2 = IT2 + I2*MM( I, 4 ) + I3*MM( I, 3 ) + I4*MM( I, 2 ) X IT1 = IT2 / IPW2 X IT2 = IT2 - IPW2*IT1 X IT1 = IT1 + I1*MM( I, 4 ) + I2*MM( I, 3 ) + I3*MM( I, 2 ) + X $ I4*MM( I, 1 ) X IT1 = MOD( IT1, IPW2 ) X* X* Convert 48-bit integer to a real number in the interval (0,1) X* X X( I ) = R*( DBLE( IT1 )+R*( DBLE( IT2 )+R*( DBLE( IT3 )+R* X $ DBLE( IT4 ) ) ) ) X 10 CONTINUE X* X* Return final value of seed X* X ISEED( 1 ) = IT1 X ISEED( 2 ) = IT2 X ISEED( 3 ) = IT3 X ISEED( 4 ) = IT4 X RETURN X* X* End of DLARUV X* X END X SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) X* X* -- LAPACK routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* February 29, 1992 X* X* .. Scalar Arguments .. X INTEGER INFO, K, LDA, M, N X* .. X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) X* .. X* X* Purpose X* ======= X* X* DORG2R generates an m by n real matrix Q with orthonormal columns, X* which is defined as the first n columns of a product of k elementary X* reflectors of order m X* X* Q = H(1) H(2) . . . H(k) X* X* as returned by DGEQRF. X* X* Arguments X* ========= X* X* M (input) INTEGER X* The number of rows of the matrix Q. M >= 0. X* X* N (input) INTEGER X* The number of columns of the matrix Q. M >= N >= 0. X* X* K (input) INTEGER X* The number of elementary reflectors whose product defines the X* matrix Q. N >= K >= 0. X* X* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) X* On entry, the i-th column must contain the vector which X* defines the elementary reflector H(i), for i = 1,2,...,k, as X* returned by DGEQRF in the first k columns of its array X* argument A. X* On exit, the m-by-n matrix Q. X* X* LDA (input) INTEGER X* The first dimension of the array A. LDA >= max(1,M). X* X* TAU (input) DOUBLE PRECISION array, dimension (K) X* TAU(i) must contain the scalar factor of the elementary X* reflector H(i), as returned by DGEQRF. X* X* WORK (workspace) DOUBLE PRECISION array, dimension (N) X* X* INFO (output) INTEGER X* = 0: successful exit X* < 0: if INFO = -i, the i-th argument has an illegal value X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ONE, ZERO X PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) X* .. X* .. Local Scalars .. X INTEGER I, J, L X* .. X* .. External Subroutines .. X EXTERNAL DLARF, DSCAL, XERBLA X* .. X* .. Intrinsic Functions .. X INTRINSIC MAX X* .. X* .. Executable Statements .. X* X* Test the input arguments X* X INFO = 0 X IF( M.LT.0 ) THEN X INFO = -1 X ELSE IF( N.LT.0 .OR. N.GT.M ) THEN X INFO = -2 X ELSE IF( K.LT.0 .OR. K.GT.N ) THEN X INFO = -3 X ELSE IF( LDA.LT.MAX( 1, M ) ) THEN X INFO = -5 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DORG2R', -INFO ) X RETURN X END IF X* X* Quick return if possible X* X IF( N.LE.0 ) X $ RETURN X* X* Initialise columns k+1:n to columns of the unit matrix X* X DO 20 J = K + 1, N X DO 10 L = 1, M X A( L, J ) = ZERO X 10 CONTINUE X A( J, J ) = ONE X 20 CONTINUE X* X DO 40 I = K, 1, -1 X* X* Apply H(i) to A(i:m,i:n) from the left X* X IF( I.LT.N ) THEN X A( I, I ) = ONE X CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), X $ A( I, I+1 ), LDA, WORK ) X END IF X IF( I.LT.M ) X $ CALL DSCAL( M-I, -TAU( I ), A( I+1, I ), 1 ) X A( I, I ) = ONE - TAU( I ) X* X* Set A(1:i-1,i) to zero X* X DO 30 L = 1, I - 1 X A( L, I ) = ZERO X 30 CONTINUE X 40 CONTINUE X RETURN X* X* End of DORG2R X* X END X SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO ) X* X* -- LAPACK routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* February 29, 1992 X* X* .. Scalar Arguments .. X INTEGER INFO, K, LDA, M, N X* .. X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) X* .. X* X* Purpose X* ======= X* X* DORG2L generates an m by n real matrix Q with orthonormal columns, X* which is defined as the last n columns of a product of k elementary X* reflectors of order m X* X* Q = H(k) . . . H(2) H(1) X* X* as returned by DGEQLF. X* X* Arguments X* ========= X* X* M (input) INTEGER X* The number of rows of the matrix Q. M >= 0. X* X* N (input) INTEGER X* The number of columns of the matrix Q. M >= N >= 0. X* X* K (input) INTEGER X* The number of elementary reflectors whose product defines the X* matrix Q. N >= K >= 0. X* X* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) X* On entry, the (n-k+i)-th column must contain the vector which X* defines the elementary reflector H(i), for i = 1,2,...,k, as X* returned by DGEQLF in the last k columns of its array X* argument A. X* On exit, the m by n matrix Q. X* X* LDA (input) INTEGER X* The first dimension of the array A. LDA >= max(1,M). X* X* TAU (input) DOUBLE PRECISION array, dimension (K) X* TAU(i) must contain the scalar factor of the elementary X* reflector H(i), as returned by DGEQLF. X* X* WORK (workspace) DOUBLE PRECISION array, dimension (N) X* X* INFO (output) INTEGER X* = 0: successful exit X* < 0: if INFO = -i, the i-th argument has an illegal value X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ONE, ZERO X PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) X* .. X* .. Local Scalars .. X INTEGER I, II, J, L X* .. X* .. External Subroutines .. X EXTERNAL DLARF, DSCAL, XERBLA X* .. X* .. Intrinsic Functions .. X INTRINSIC MAX X* .. X* .. Executable Statements .. X* X* Test the input arguments X* X INFO = 0 X IF( M.LT.0 ) THEN X INFO = -1 X ELSE IF( N.LT.0 .OR. N.GT.M ) THEN X INFO = -2 X ELSE IF( K.LT.0 .OR. K.GT.N ) THEN X INFO = -3 X ELSE IF( LDA.LT.MAX( 1, M ) ) THEN X INFO = -5 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DORG2L', -INFO ) X RETURN X END IF X* X* Quick return if possible X* X IF( N.LE.0 ) X $ RETURN X* X* Initialise columns 1:n-k to columns of the unit matrix X* X DO 20 J = 1, N - K X DO 10 L = 1, M X A( L, J ) = ZERO X 10 CONTINUE X A( M-N+J, J ) = ONE X 20 CONTINUE X* X DO 40 I = 1, K X II = N - K + I X* X* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left X* X A( M-N+II, II ) = ONE X CALL DLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A, X $ LDA, WORK ) X CALL DSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 ) X A( M-N+II, II ) = ONE - TAU( I ) X* X* Set A(m-k+i+1:m,n-k+i) to zero X* X DO 30 L = M - N + II + 1, M X A( L, II ) = ZERO X 30 CONTINUE X 40 CONTINUE X RETURN X* X* End of DORG2L X* X END X SUBROUTINE DLAGTS( JOB, N, A, B, C, D, IN, Y, TOL, INFO ) X* X* -- LAPACK auxiliary routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* October 31, 1992 X* X* .. Scalar Arguments .. X INTEGER INFO, JOB, N X DOUBLE PRECISION TOL X* .. X* .. Array Arguments .. X INTEGER IN( * ) X DOUBLE PRECISION A( * ), B( * ), C( * ), D( * ), Y( * ) X* .. X* X* Purpose X* ======= X* X* DLAGTS may be used to solve one of the systems of equations X* X* (T - lambda*I)*x = y or (T - lambda*I)'*x = y, X* X* where T is an n by n tridiagonal matrix, for x, following the X* factorization of (T - lambda*I) as X* X* (T - lambda*I) = P*L*U , X* X* by routine DLAGTF. The choice of equation to be solved is X* controlled by the argument JOB, and in each case there is an option X* to perturb zero or very small diagonal elements of U, this option X* being intended for use in applications such as inverse iteration. X* X* Arguments X* ========= X* X* JOB (input) INTEGER X* Specifies the job to be performed by DLAGTS as follows: X* = 1: The equations (T - lambda*I)x = y are to be solved, X* but diagonal elements of U are not to be perturbed. X* = -1: The equations (T - lambda*I)x = y are to be solved X* and, if overflow would otherwise occur, the diagonal X* elements of U are to be perturbed. See argument TOL X* below. X* = 2: The equations (T - lambda*I)'x = y are to be solved, X* but diagonal elements of U are not to be perturbed. X* = -2: The equations (T - lambda*I)'x = y are to be solved X* and, if overflow would otherwise occur, the diagonal X* elements of U are to be perturbed. See argument TOL X* below. X* X* N (input) INTEGER X* The order of the matrix T. X* X* A (input) DOUBLE PRECISION array, dimension (N) X* On entry, A must contain the diagonal elements of U as X* returned from DLAGTF. X* X* B (input) DOUBLE PRECISION array, dimension (N-1) X* On entry, B must contain the first super-diagonal elements of X* U as returned from DLAGTF. X* X* C (input) DOUBLE PRECISION array, dimension (N-1) X* On entry, C must contain the sub-diagonal elements of L as X* returned from DLAGTF. X* X* D (input) DOUBLE PRECISION array, dimension (N-2) X* On entry, D must contain the second super-diagonal elements X* of U as returned from DLAGTF. X* X* IN (input) INTEGER array, dimension (N) X* On entry, IN must contain details of the matrix P as returned X* from DLAGTF. X* X* Y (input/output) DOUBLE PRECISION array, dimension (N) X* On entry, the right hand side vector y. X* On exit, Y is overwritten by the solution vector x. X* X* TOL (input/output) DOUBLE PRECISION X* On entry, with JOB .lt. 0, TOL should be the minimum X* perturbation to be made to very small diagonal elements of U. X* TOL should normally be chosen as about eps*norm(U), where eps X* is the relative machine precision, but if TOL is supplied as X* non-positive, then it is reset to eps*max( abs( u(i,j) ) ). X* If JOB .gt. 0 then TOL is not referenced. X* X* On exit, TOL is changed as described above, only if TOL is X* non-positive on entry. Otherwise TOL is unchanged. X* X* INFO (output) INTEGER X* = 0 : successful exit X* .lt. 0: if INFO = -i, the i-th argument had an illegal value X* .gt. 0: overflow would occur when computing the INFO(th) X* element of the solution vector x. This can only occur X* when JOB is supplied as positive and either means X* that a diagonal element of U is very small, or that X* the elements of the right-hand side vector y are very X* large. X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ONE, ZERO X PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) X* .. X* .. Local Scalars .. X INTEGER K X DOUBLE PRECISION ABSAK, AK, BIGNUM, EPS, PERT, SFMIN, TEMP X* .. X* .. Intrinsic Functions .. X INTRINSIC ABS, MAX, SIGN X* .. X* .. External Functions .. X DOUBLE PRECISION DLAMCH X EXTERNAL DLAMCH X* .. X* .. External Subroutines .. X EXTERNAL XERBLA X* .. X* .. Executable Statements .. X* X INFO = 0 X IF( ( ABS( JOB ).GT.2 ) .OR. ( JOB.EQ.0 ) ) THEN X INFO = -1 X ELSE IF( N.LT.0 ) THEN X INFO = -2 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DLAGTS', -INFO ) X RETURN X END IF X* X IF( N.EQ.0 ) X $ RETURN X* X EPS = DLAMCH( 'Epsilon' ) X SFMIN = DLAMCH( 'Safe minimum' ) X BIGNUM = ONE / SFMIN X* X IF( JOB.LT.0 ) THEN X IF( TOL.LE.ZERO ) THEN X TOL = ABS( A( 1 ) ) X IF( N.GT.1 ) X $ TOL = MAX( TOL, ABS( A( 2 ) ), ABS( B( 1 ) ) ) X DO 10 K = 3, N X TOL = MAX( TOL, ABS( A( K ) ), ABS( B( K-1 ) ), X $ ABS( D( K-2 ) ) ) X 10 CONTINUE X TOL = TOL*EPS X IF( TOL.EQ.ZERO ) X $ TOL = EPS X END IF X END IF X* X IF( ABS( JOB ).EQ.1 ) THEN X DO 20 K = 2, N X IF( IN( K-1 ).EQ.0 ) THEN X Y( K ) = Y( K ) - C( K-1 )*Y( K-1 ) X ELSE X TEMP = Y( K-1 ) X Y( K-1 ) = Y( K ) X Y( K ) = TEMP - C( K-1 )*Y( K ) X END IF X 20 CONTINUE X IF( JOB.EQ.1 ) THEN X DO 30 K = N, 1, -1 X IF( K.LE.N-2 ) THEN X TEMP = Y( K ) - B( K )*Y( K+1 ) - D( K )*Y( K+2 ) X ELSE IF( K.EQ.N-1 ) THEN X TEMP = Y( K ) - B( K )*Y( K+1 ) X ELSE X TEMP = Y( K ) X END IF X AK = A( K ) X ABSAK = ABS( AK ) X IF( ABSAK.LT.ONE ) THEN X IF( ABSAK.LT.SFMIN ) THEN X IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK ) X $ THEN X INFO = K X RETURN X ELSE X TEMP = TEMP*BIGNUM X AK = AK*BIGNUM X END IF X ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN X INFO = K X RETURN X END IF X END IF X Y( K ) = TEMP / AK X 30 CONTINUE X ELSE X DO 50 K = N, 1, -1 X IF( K.LE.N-2 ) THEN X TEMP = Y( K ) - B( K )*Y( K+1 ) - D( K )*Y( K+2 ) X ELSE IF( K.EQ.N-1 ) THEN X TEMP = Y( K ) - B( K )*Y( K+1 ) X ELSE X TEMP = Y( K ) X END IF X AK = A( K ) X PERT = SIGN( TOL, AK ) X 40 CONTINUE X ABSAK = ABS( AK ) X IF( ABSAK.LT.ONE ) THEN X IF( ABSAK.LT.SFMIN ) THEN X IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK ) X $ THEN X AK = AK + PERT X PERT = 2*PERT X GO TO 40 X ELSE X TEMP = TEMP*BIGNUM X AK = AK*BIGNUM X END IF X ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN X AK = AK + PERT X PERT = 2*PERT X GO TO 40 X END IF X END IF X Y( K ) = TEMP / AK X 50 CONTINUE X END IF X ELSE X* X* Come to here if JOB = 2 or -2 X* X IF( JOB.EQ.2 ) THEN X DO 60 K = 1, N X IF( K.GE.3 ) THEN X TEMP = Y( K ) - B( K-1 )*Y( K-1 ) - D( K-2 )*Y( K-2 ) X ELSE IF( K.EQ.2 ) THEN X TEMP = Y( K ) - B( K-1 )*Y( K-1 ) X ELSE X TEMP = Y( K ) X END IF X AK = A( K ) X ABSAK = ABS( AK ) X IF( ABSAK.LT.ONE ) THEN X IF( ABSAK.LT.SFMIN ) THEN X IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK ) X $ THEN X INFO = K X RETURN X ELSE X TEMP = TEMP*BIGNUM X AK = AK*BIGNUM X END IF X ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN X INFO = K X RETURN X END IF X END IF X Y( K ) = TEMP / AK X 60 CONTINUE X ELSE X DO 80 K = 1, N X IF( K.GE.3 ) THEN X TEMP = Y( K ) - B( K-1 )*Y( K-1 ) - D( K-2 )*Y( K-2 ) X ELSE IF( K.EQ.2 ) THEN X TEMP = Y( K ) - B( K-1 )*Y( K-1 ) X ELSE X TEMP = Y( K ) X END IF X AK = A( K ) X PERT = SIGN( TOL, AK ) X 70 CONTINUE X ABSAK = ABS( AK ) X IF( ABSAK.LT.ONE ) THEN X IF( ABSAK.LT.SFMIN ) THEN X IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK ) X $ THEN X AK = AK + PERT X PERT = 2*PERT X GO TO 70 X ELSE X TEMP = TEMP*BIGNUM X AK = AK*BIGNUM X END IF X ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN X AK = AK + PERT X PERT = 2*PERT X GO TO 70 X END IF X END IF X Y( K ) = TEMP / AK X 80 CONTINUE X END IF X* X DO 90 K = N, 2, -1 X IF( IN( K-1 ).EQ.0 ) THEN X Y( K-1 ) = Y( K-1 ) - C( K-1 )*Y( K ) X ELSE X TEMP = Y( K-1 ) X Y( K-1 ) = Y( K ) X Y( K ) = TEMP - C( K-1 )*Y( K ) X END IF X 90 CONTINUE X END IF X* X* End of DLAGTS X* X END X SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) X* X* -- LAPACK auxiliary routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* February 29, 1992 X* X* .. Scalar Arguments .. X CHARACTER SIDE X INTEGER INCV, LDC, M, N X DOUBLE PRECISION TAU X* .. X* .. Array Arguments .. X DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) X* .. X* X* Purpose X* ======= X* X* DLARF applies a real elementary reflector H to a real m by n matrix X* C, from either the left or the right. H is represented in the form X* X* H = I - tau * v * v' X* X* where tau is a real scalar and v is a real vector. X* X* If tau = 0, then H is taken to be the unit matrix. X* X* Arguments X* ========= X* X* SIDE (input) CHARACTER*1 X* = 'L': form H * C X* = 'R': form C * H X* X* M (input) INTEGER X* The number of rows of the matrix C. X* X* N (input) INTEGER X* The number of columns of the matrix C. X* X* V (input) DOUBLE PRECISION array, dimension X* (1 + (M-1)*abs(INCV)) if SIDE = 'L' X* or (1 + (N-1)*abs(INCV)) if SIDE = 'R' X* The vector v in the representation of H. V is not used if X* TAU = 0. X* X* INCV (input) INTEGER X* The increment between elements of v. INCV <> 0. X* X* TAU (input) DOUBLE PRECISION X* The value tau in the representation of H. X* X* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) X* On entry, the m by n matrix C. X* On exit, C is overwritten by the matrix H * C if SIDE = 'L', X* or C * H if SIDE = 'R'. X* X* LDC (input) INTEGER X* The leading dimension of the array C. LDC >= max(1,M). X* X* WORK (workspace) DOUBLE PRECISION array, dimension X* (N) if SIDE = 'L' X* or (M) if SIDE = 'R' X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ONE, ZERO X PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) X* .. X* .. External Subroutines .. X EXTERNAL DGEMV, DGER X* .. X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. X* .. Executable Statements .. X* X IF( LSAME( SIDE, 'L' ) ) THEN X* X* Form H * C X* X IF( TAU.NE.ZERO ) THEN X* X* w := C' * v X* X CALL DGEMV( 'Transpose', M, N, ONE, C, LDC, V, INCV, ZERO, X $ WORK, 1 ) X* X* C := C - v * w' X* X CALL DGER( M, N, -TAU, V, INCV, WORK, 1, C, LDC ) X END IF X ELSE X* X* Form C * H X* X IF( TAU.NE.ZERO ) THEN X* X* w := C * v X* X CALL DGEMV( 'No transpose', M, N, ONE, C, LDC, V, INCV, X $ ZERO, WORK, 1 ) X* X* C := C - w * v' X* X CALL DGER( M, N, -TAU, WORK, 1, V, INCV, C, LDC ) X END IF X END IF X RETURN X* X* End of DLARF X* X END X* X SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) X* X* -- LAPACK auxiliary routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* September 30, 1994 X* X* .. Scalar Arguments .. X INTEGER INCX, N X DOUBLE PRECISION ALPHA, TAU X* .. X* .. Array Arguments .. X DOUBLE PRECISION X( * ) X* .. X* X* Purpose X* ======= X* X* DLARFG generates a real elementary reflector H of order n, such X* that X* X* H * ( alpha ) = ( beta ), H' * H = I. X* ( x ) ( 0 ) X* X* where alpha and beta are scalars, and x is an (n-1)-element real X* vector. H is represented in the form X* X* H = I - tau * ( 1 ) * ( 1 v' ) , X* ( v ) X* X* where tau is a real scalar and v is a real (n-1)-element X* vector. X* X* If the elements of x are all zero, then tau = 0 and H is taken to be X* the unit matrix. X* X* Otherwise 1 <= tau <= 2. X* X* Arguments X* ========= X* X* N (input) INTEGER X* The order of the elementary reflector. X* X* ALPHA (input/output) DOUBLE PRECISION X* On entry, the value alpha. X* On exit, it is overwritten with the value beta. X* X* X (input/output) DOUBLE PRECISION array, dimension X* (1+(N-2)*abs(INCX)) X* On entry, the vector x. X* On exit, it is overwritten with the vector v. X* X* INCX (input) INTEGER X* The increment between elements of X. INCX > 0. X* X* TAU (output) DOUBLE PRECISION X* The value tau. X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ONE, ZERO X PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) X* .. X* .. Local Scalars .. X INTEGER J, KNT X DOUBLE PRECISION BETA, RSAFMN, SAFMIN, XNORM X* .. X* .. External Functions .. X DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2 X EXTERNAL DLAMCH, DLAPY2, DNRM2 X* .. X* .. Intrinsic Functions .. X INTRINSIC ABS, SIGN X* .. X* .. External Subroutines .. X EXTERNAL DSCAL X* .. X* .. Executable Statements .. X* X IF( N.LE.1 ) THEN X TAU = ZERO X RETURN X END IF X* X XNORM = DNRM2( N-1, X, INCX ) X* X IF( XNORM.EQ.ZERO ) THEN X* X* H = I X* X TAU = ZERO X ELSE X* X* general case X* X BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) X SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' ) X IF( ABS( BETA ).LT.SAFMIN ) THEN X* X* XNORM, BETA may be inaccurate; scale X and recompute them X* X RSAFMN = ONE / SAFMIN X KNT = 0 X 10 CONTINUE X KNT = KNT + 1 X CALL DSCAL( N-1, RSAFMN, X, INCX ) X BETA = BETA*RSAFMN X ALPHA = ALPHA*RSAFMN X IF( ABS( BETA ).LT.SAFMIN ) X $ GO TO 10 X* X* New BETA is at most 1, at least SAFMIN X* X XNORM = DNRM2( N-1, X, INCX ) X BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) X TAU = ( BETA-ALPHA ) / BETA X CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) X* X* If ALPHA is subnormal, it may lose relative accuracy X* X ALPHA = BETA X DO 20 J = 1, KNT X ALPHA = ALPHA*SAFMIN X 20 CONTINUE X ELSE X TAU = ( BETA-ALPHA ) / BETA X CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) X ALPHA = BETA X END IF X END IF X* X RETURN X* X* End of DLARFG X* X END X END_OF_FILE if test 393036 -ne `wc -c <'lapack.f'`; then echo shar: \"'lapack.f'\" unpacked with wrong size! fi # end of 'lapack.f' fi if test -f 'matvec.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'matvec.f'\" else echo shar: Extracting \"'matvec.f'\" \(5215 characters\) sed "s/^X//" >'matvec.f' <<'END_OF_FILE' X*----------------------------------------------------------------------| X* FILE X* matvec.f - matrix-vector multiplication routines X* X* This module is where to add routine(s) for matrix-vector products X* when the matrix is in a format not currently supported by default. X* The first subroutine matvec(m,x,ldx,y,ldy) of this file should X* be modified as directed therein. X* X* CONTENTS X* subroutine matvec(m, x,ldx, y,ldy) - wrapper to call other mat-vec X* subroutine matv1( x, y) - single (ie., non-block) mat-vec X* subroutine hbovec(m, x,ldx, y,ldy) - block mat-vec with HBO/CCS X* subroutine coovec(m, x,ldx, y,ldy) - block mat-vec with COO X* X* DESCRIPTION X* X* #####################################################################| X* subroutine matvec( m, x,ldx, y,ldy ) X* Purpose X* wrapper that calls the relevant routine to perform a block X* matrix-vector multiplication depending on the type of the matrix X* at hand. X* Called Routines X* internal: hbovec(m, x,ldx, y,ldy) - mat-vec with a HBO/CCS matrix X* internal: coovec(m, x,ldx, y,ldy) - mat-vec with a COO matrix X* Calling Routines X* runme.f: -main- X* X* #####################################################################| X* subroutine matv1( x, y ) X* Purpose X* simple wrapper that calls the block-matvec to do a single-matvec X* Called Routines X* internal: matvec(m, x,ldx, y,ldy) - wrapper to call other mat-vec X* Calling Routines X* correc.f: corrEX(m, ritzv, x,ldx, r,ldr) - exponential corrector X* X* #####################################################################| X* subroutine hobvec( m, x,ldx, y,ldy ) X* Purpose X* computes y(:,1:m) = A*x(:,1:m) where A is a symmetric matrix under X* the (lower-half) Harwell-Boeing format (HBO) or the (lower-half) X* Compressed Column Storage format (CCS). X* Called Routines X* internal: matvec(m, x,ldx, y,ldy) - wrapper to call other mat-vec X* Calling Routines X* -none- X* X* #####################################################################| X* subroutine coovec( m, x,ldx, y,ldy ) X* Purpose X* computes y(:,1:m) = A*x(:,1:m), A complete (not half) COOrdinate X* Called Routines X* internal: matvec(m, x,ldx, y,ldy) - wrapper to call other mat-vec X* Calling Routines X* -none- X* X* END DESCRIPTION X*----------------------------------------------------------------------| X* X* AUTHORS X* X* M. Sadkane - sadkane@univ-brest.fr R. B. Sidje - rbs@maths.uq.edu.au X* Departement de Mathematiques Department of Mathematics X* Universite de Bretagne Occidentale University of Queensland X* 6, Avenue Le Gorgeu, B.P. 809 Brisbane QLD 4072 X* 29285 Brest Cedex. France Australia X* X* REVISION DATE: 11/JAN/1999 X*----------------------------------------------------------------------| X X subroutine matvec( m, x,ldx, y,ldy ) X include 'common.inc' X integer m, ldx, ldy X double precision x(ldx,m), y(ldy,m) X* X*--- Add call(s) to your block matrix-vector routine(s) according to X* the model: if ( c_mattype(1:3).eq.'xxx' ) call your_matvec( ... ) X* The block matrix-vector routine computes y(:,1:m) = A*x(:,1:m) X* On input: X* x(1:n,1:m) are the current approximate eigenvectors X* On output: X* y(1:n,1:m) are the matrix-vector products X* x(1:n,1:m) should not be altered. X*--- X if ( c_mattype(1:3).eq.'hbo' ) call hbovec( m, x,ldx, y,ldy ) X if ( c_mattype(1:3).eq.'coo' ) call coovec( m, x,ldx, y,ldy ) X if ( c_mattype(1:3).eq.'ccs' ) call hbovec( m, x,ldx, y,ldy ) X c_nmult = c_nmult + m X end X*----------------------------------------------------------------------| X subroutine matv1( x, y ) X*--- simple wrapper that calls the block-matvec to do a single-matvec X double precision x(1), y(1) X call matvec( 1, x,1, y,1 ) X end X*----------------------------------------------------------------------| X subroutine hbovec( m, x,ldx, y,ldy ) X include 'common.inc' X integer m, ldx, ldy X double precision x(ldx,m), y(ldy,m) X* X*--- computes y = A*x, A is a HBO/CCS symmetric matrix (lower half)... X* X integer i, j, k, i1, i2 X* X do k = 1,m X do i = 1,c_N X y(i,k) = 0.0d0 X enddo X enddo X do j = 1,c_N X i1 = c_ja(j) X i2 = c_ja(j+1) - 1 X do k = 1,m X do i = i1,i2 X y(c_ia(i),k) = y(c_ia(i),k) + c_a(i)*x(j,k) X enddo X do i = i1+1,i2 X y(j,k) = y(j,k) + c_a(i)*x(c_ia(i),k) X enddo X enddo X enddo X end X*----------------------------------------------------------------------| X subroutine coovec( m, x,ldx, y,ldy ) X include 'common.inc' X integer m, ldx, ldy X double precision x(ldx,m), y(ldy,m) X* X*--- computes y = A*x, A is a complete (not half) COOrdinate matrix... X* X integer i, k X* X do k = 1,m X do i = 1,c_N X y(i,k) = 0.0d0 X enddo X enddo X do i = 1,c_NZ X do k = 1,m X y(c_ia(i),k) = y(c_ia(i),k) + c_a(i)*x(c_ja(i),k) X enddo X enddo X end X*----------------------------------------------------------------------| END_OF_FILE if test 5215 -ne `wc -c <'matvec.f'`; then echo shar: \"'matvec.f'\" unpacked with wrong size! fi # end of 'matvec.f' fi if test -f 'randm.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'randm.f'\" else echo shar: Extracting \"'randm.f'\" \(5254 characters\) sed "s/^X//" >'randm.f' <<'END_OF_FILE' X*----------------------------------------------------------------------| X* FILE X* randm.f - generate a matrix of random values X* X* CONTENTS X* subroutine randm( n,m, a,b, x,ldx ) X* DOUBLE PRECISION FUNCTION DLARAN( ISEED ) X* X* DESCRIPTION X* X* #####################################################################| X* subroutine randm( n,m, a,b, x,ldx ) X* Purpose X* fills x(1:n,1:m) with random numbers chosen from a uniform X* distribution in the interval (a,b). If a = b, then x is set to X* the first m columns of the n-by-n identity matrix. X* Called Routines X* internal: DLARAN( ISEED ) - uniform (0,1) random number generator X* Calling Routines X* getmat.f: gethbo( x,ldx ) - load Harwell-Boeing matrix X* getmat.f: getcoo( x,ldx ) - load COOrdinates matrix X* getmat.f: getcss( x,ldx ) - load Compressed Column Storage matrix X* X* #####################################################################| X* DOUBLE PRECISION FUNCTION DLARAN( ISEED ) X* Purpose X* This routine is taken from the LAPACK testing suite. X* It returns a random real number from a uniform (0,1) distribution X* Called Routines X* -none- X* Calling Routines X* internal: randm(n,m,a,b,x,ldx) - x(1:n,1:m)=random values in (a,b) X* X* END DESCRIPTION X*----------------------------------------------------------------------| X* X* AUTHORS X* X* M. Sadkane - sadkane@univ-brest.fr R. B. Sidje - rbs@maths.uq.edu.au X* Departement de Mathematiques Department of Mathematics X* Universite de Bretagne Occidentale University of Queensland X* 6, Avenue Le Gorgeu, B.P. 809 Brisbane QLD 4072 X* 29285 Brest Cedex. France Australia X* X* REVISION DATE: 11/JAN/1999 X*----------------------------------------------------------------------| X X subroutine randm( n,m, a,b, x,ldx ) X integer n, m, ldx X double precision a, b, x(ldx,m) X X*--- fills x(1:n,1:m) with random numbers chosen from a uniform X* distribution in the interval (a,b). If a = b, then x is set to X* the first m columns of the identity matrix of order m. X* X integer i, j, iseed(4) X double precision c, DLARAN X* X iseed(1) = 1 X iseed(2) = 3 X iseed(3) = 5 X iseed(4) = 7 X X c = b - a X do j = 1,m X if ( c.eq.0.0d0 ) then X do i = 1,n X x(i,j) = 0.0d0 X enddo X x(j,j) = 1.0d0 X else X do i = 1,n X x(i,j) = a + c * DLARAN( iseed ) X enddo X endif X enddo X end X*----------------------------------------------------------------------| X DOUBLE PRECISION FUNCTION DLARAN( ISEED ) X* X* -- LAPACK auxiliary routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* February 29, 1992 X* X* .. Array Arguments .. X INTEGER ISEED( 4 ) X* .. X* X* Purpose X* ======= X* X* DLARAN returns a random real number from a uniform (0,1) X* distribution. X* X* Arguments X* ========= X* X* ISEED (input/output) INTEGER array, dimension (4) X* On entry, the seed of the random number generator; the array X* elements must be between 0 and 4095, and ISEED(4) must be X* odd. X* On exit, the seed is updated. X* X* Further Details X* =============== X* X* This routine uses a multiplicative congruential method with modulus X* 2**48 and multiplier 33952834046453 (see G.S.Fishman, X* 'Multiplicative congruential random number generators with modulus X* 2**b: an exhaustive analysis for b = 32 and a partial analysis for X* b = 48', Math. Comp. 189, pp 331-344, 1990). X* X* 48-bit integers are stored in 4 integer array elements with 12 bits X* per element. Hence the routine is portable across machines with X* integers of 32 bits or more. X* X* ===================================================================== X* X* .. Parameters .. X INTEGER M1, M2, M3, M4 X PARAMETER ( M1 = 494, M2 = 322, M3 = 2508, M4 = 2549 ) X DOUBLE PRECISION ONE X PARAMETER ( ONE = 1.0D+0 ) X INTEGER IPW2 X DOUBLE PRECISION R X PARAMETER ( IPW2 = 4096, R = ONE / IPW2 ) X* .. X* .. Local Scalars .. X INTEGER IT1, IT2, IT3, IT4 X* .. X* .. Intrinsic Functions .. X INTRINSIC DBLE, MOD X* .. X* .. Executable Statements .. X* X* multiply the seed by the multiplier modulo 2**48 X* X IT4 = ISEED( 4 )*M4 X IT3 = IT4 / IPW2 X IT4 = IT4 - IPW2*IT3 X IT3 = IT3 + ISEED( 3 )*M4 + ISEED( 4 )*M3 X IT2 = IT3 / IPW2 X IT3 = IT3 - IPW2*IT2 X IT2 = IT2 + ISEED( 2 )*M4 + ISEED( 3 )*M3 + ISEED( 4 )*M2 X IT1 = IT2 / IPW2 X IT2 = IT2 - IPW2*IT1 X IT1 = IT1 + ISEED( 1 )*M4 + ISEED( 2 )*M3 + ISEED( 3 )*M2 + X $ ISEED( 4 )*M1 X IT1 = MOD( IT1, IPW2 ) X* X* return updated seed X* X ISEED( 1 ) = IT1 X ISEED( 2 ) = IT2 X ISEED( 3 ) = IT3 X ISEED( 4 ) = IT4 X* X* convert 48-bit integer to a real number in the interval (0,1) X* X DLARAN = R*( DBLE( IT1 )+R*( DBLE( IT2 )+R*( DBLE( IT3 )+R* X $ ( DBLE( IT4 ) ) ) ) ) X RETURN X* X* End of DLARAN X* X END END_OF_FILE if test 5254 -ne `wc -c <'randm.f'`; then echo shar: \"'randm.f'\" unpacked with wrong size! fi # end of 'randm.f' fi if test -f 'runme.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'runme.f'\" else echo shar: Extracting \"'runme.f'\" \(6964 characters\) sed "s/^X//" >'runme.f' <<'END_OF_FILE' X*----------------------------------------------------------------------| X* FILE X* runme.f - driver using external data - X* This driver illustrates the use of the configurable X* environment of the whole Davidson package. X* This environment allows repeating the computations X* with different settings through an initialization file. X* X* syntax: runme [name-of-initialization-file] X* X* If no initialization file is specified on the command line, the X* code will consider init.data as the default initialization file. X* If the file init.data does not exist, the code will use default X* initialization values and will prompt the user for the name of a X* file containing a Harwell-Boeing matrix. X* X* When the matrix is loaded, the data needed for the corrector (or X* preconditioner) are retrieved or computed from the matrix. X* If the user has specified an initial guess file, initial guess X* vectors are read from the user's file, otherwise, they are X* generated randomly. Matrix and corrector data sets are passed X* through common blocks that are declared in the file common.inc. X* X* The initialization steps described above are handled by the X* routine input( x,ldx ) which is called in the first statement of X* this program. X* X* After these initializations, the program then takes the common X* variables to assign the input arguments expected in the Davidson X* eigensolver: X* n = order of the matrix X* nbx = maximum allowable size of the basis X* nb = initial block-size X* nev = number of wanted eigenpairs X* itmax = maximum allowable number of iterations (i.e., restarts) X* tol = accuracy tolerance X* ilevel = level of information to be reported X* iunit = unit where the information should be reported (6 = screen) X* anorm = estimate of some norm of A. This parameter provides a X* means to select a particular convergence test: X* - If anorm>0.0d0, an eigenpair (x,lambda) is accepted if X* the relative residual ||A*x - lambda*x||/anorm <= tol. X* If anorm=1.0d0, the test is therefore based on the X* absolute residual ||A*x - lambda*x|| <= tol. X* - If anorm=0.0d0, the code uses the relative residual X* ||A*x - lambda*x||/MAX(eps^{2/3},ABS(lambda)) <= tol. X* `eps' is the machine unit roundoff (computed internally) X* X* After these initializations, the eigensolver itself is called. X* Then the computed eigenpairs are sorted and the results printed. X* X* CONTENTS X* double precision function timer( ) - simple utility timer routine X* X* CALLED ROUTINES X* include 'common.inc' X* io.f: input( x,ldx ) - initialize the argument variables X* io.f: output(res,eig,x,ldx) - output results of computation X* davpack.f: davson(...) - Variable-Block Davidson with deflation X* eigsrt.f: eigsrt( n, nev, res, eig, x,ldx ) - sort eigenpairs X* matvec.f: matvec(...) - block matrix-vector multiplication routine X* correc.f: correc(...) - corrector routine X* internal: timer( ) - simple utility timer routine (seconds) X* X* DESCRIPTION X* X* #####################################################################| X* double precision function timer( ) X* Purpose X* This is a simple utility timer routine (seconds) modelled on top X* of SUN' etime function. Users must change the call to "etime" X* as appropriate to suit their environments. X* X* END DESCRIPTION X*----------------------------------------------------------------------| X* X* AUTHORS X* X* M. Sadkane - sadkane@univ-brest.fr R. B. Sidje - rbs@maths.uq.edu.au X* Departement de Mathematiques Department of Mathematics X* Universite de Bretagne Occidentale University of Queensland X* 6, Avenue Le Gorgeu, B.P. 809 Brisbane QLD 4072 X* 29285 Brest Cedex. France Australia X* X* REVISION DATE: 11/JAN/1999 X*----------------------------------------------------------------------| X X program RUNME X include 'common.inc' X external matvec, correc X X integer nbxx, liwork, lwork, ldx X parameter( ldx= c_nmax, nbxx= 100 ) X parameter( liwork= 6*nbxx ) X parameter( lwork= 10*ldx + (ldx+nbxx)*(nbxx+10) + (ldx+8)*nbxx ) X integer n, nbx, nb, nev, itmax, iter, nmult, ilevel, iunit X integer iwork(liwork), ifail X double precision res(10), eig(10), x(ldx,10), work(lwork) X double precision tol, anorm, t0, t1 X X double precision timer X intrinsic ABS, INDEX, MAX X* X*======================================================================| X*--- Get the matrix, make up the corrector, get initial guesses X call input( x,ldx ) X X*======================================================================| X*--- Setup input arguments of DAVSON ... X n = c_n X nbx = c_basis X nb = c_block X nev = c_eigenpair X itmax = c_iteration X tol = c_tol X ilevel= c_infolevel X iunit = c_stdout X anorm = 0.0d0 X X*======================================================================| X*--- Compute the desired eigenpairs ... X t0 = timer( ) X call davson( n, nbx, nb, nev, itmax, iter, nmult, tol, X . anorm, res, eig, x,ldx, work,lwork, iwork,liwork, X . matvec, correc, ilevel, iunit, ifail ) X t1 = timer( ) X X*======================================================================| X*--- Sort the eigenpairs with respect to eigenvalues or residuals X call eigsrt( n, ABS(c_eigenpair), res, eig, x,ldx ) X X*======================================================================| X*--- Output X write(c_stdout,'(A,1P,E11.3)') 'Runtime (seconds):', t1-t0 X write(c_stdout,'("Total number of iterations used:",1P,I4)') iter X call output( res, eig, x,ldx ) X X*======================================================================| X*--- WARNING: on a SUN system, at the end of the output, the following X* note may appear (without affecting the correctness of the results) X*--- X* Note: the following IEEE floating-point arithmetic exceptions X* occurred and were never cleared; see ieee_flags(3M): X* Inexact; Underflow; X* Sun's implementation of IEEE arithmetic is discussed in X* the Numerical Computation Guide. X*--- X end X*----------------------------------------------------------------------| X*::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::| X*::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::| X*::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::| X*----------------------------------------------------------------------| X*--- Simple utility timer routine (seconds) X* Modify as appropriate to suit your environment X double precision function timer( ) X real*4 etime, tm(2) X timer = etime( tm ) X end END_OF_FILE if test 6964 -ne `wc -c <'runme.f'`; then echo shar: \"'runme.f'\" unpacked with wrong size! fi # end of 'runme.f' fi echo shar: End of shell archive. exit 0