#!/bin/sh # This is a shell archive (produced by shar 3.49) # To extract the files from this archive, save it to a file, remove # everything above the "!/bin/sh" line above, and type "sh file_name". # # existing files will NOT be overwritten unless -c is specified # # This shar contains: # length mode name # ------ ---------- ------------------------------------------ # 24247 -rw------- dble/README # 5212 -rw------- dble/makefile # 5850 -rw------- dble/v.dat # 5850 -rw------- dble/w.dat # 959 -rw------- dble/local.mak # 2412 -rw------- dble/skeleton.mak # 5400 -rw------- dble/x.dat # 20 -rw------- dble/version.h # 770 -rw------- dble/bru/axb.inc # 1579 -rw------- dble/bru/cpyrit.doc # 9536 -rw------- dble/bru/daxb.f # 2013 -rw------- dble/bru/daxbpr.f # 1077 -rw------- dble/bru/makefile # 1579 -rw------- dble/csr/cpyrit.doc # 999 -rw------- dble/csr/csr.inc # 8640 -rw------- dble/csr/dcilut.f # 7610 -rw------- dble/csr/dclilut.f # 6513 -rw------- dble/csr/dclssor.f # 7610 -rw------- dble/csr/dcrilut.f # 6521 -rw------- dble/csr/dcrssor.f # 10293 -rw------- dble/csr/dcsr.f # 9872 -rw------- dble/csr/ilut.f # 2395 -rw------- dble/csr/makefile # 6422 -rw------- dble/csr/sparskit.f # 9603 -rw------- dble/dat/dns.dat # 480 -rw------- dble/dat/dnsv.dat # 480 -rw------- dble/dat/dnsw.dat # 29298 -rw------- dble/dat/csr.dat # 5400 -rw------- dble/dat/csrx.dat # 5850 -rw------- dble/dat/csrv.dat # 5850 -rw------- dble/dat/csrw.dat # 1579 -rw------- dble/dns/cpyrit.doc # 5671 -rw------- dble/dns/ddlssor.f # 6294 -rw------- dble/dns/ddns.f # 5575 -rw------- dble/dns/ddrssor.f # 750 -rw------- dble/dns/dns.inc # 1600 -rw------- dble/dns/makefile # 224 -rw------- dble/inc/dimblk.inc # 155 -rw------- dble/inc/precon.inc # 1579 -rw------- dble/lal/cpyrit.doc # 2725 -rw------- dble/lal/dcoeff.f # 1597 -rw------- dble/lal/dlal.inc # 13813 -rw------- dble/lal/deig.F # 13177 -rw------- dble/lal/deiglal.F # 23494 -rw------- dble/lal/dlal.F # 1266 -rw------- dble/lal/getomg.f # 8607 -rw------- dble/lal/dsys.F # 28685 -rw------- dble/lal/dsysbcg.F # 26481 -rw------- dble/lal/dsyslal.F # 1502 -rw------- dble/lal/makefile # 1558 -rw------- dble/sup/cpyrit.doc # 42496 -rw------- dble/sup/linpack.f # 3728 -rw------- dble/sup/support.f # 38090 -rw------- dble/sup/eispack.f # 1016 -rw------- dble/sup/makefile # # ============= dble/README ============== if test ! -d 'dble'; then echo 'x - creating directory dble' mkdir 'dble' fi if test -f 'dble/README' -a X"$1" != X"-c"; then echo 'x - skipping dble/README (File already exists)' else echo 'x - extracting dble/README (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/README' && X X X December 31, 1993 X Update Info ----------- X The codes in this package have been upgraded and expanded to a new package, called QMRPACK. We retain this package only for historical reasons, and recommend the use of the codes in QMRPACK. The new package is distributed in the form of the compressed tar file "qmrpack.tar.Z" in the "linalg" section of NETLIB. You can obtain QMRPACK by using xnetlib or by anonymous ftp. In the latter case, ftp to "netlib.att.com" and then get the file "qmrpack.tar.Z" from the directory "netlib/linalg". X The package provides two different implementations of QMR, one based on three-term recurrences, and one based on coupled two-term recurrences. Since several people find it desirable to have iterative methods that require only a few lines of code, we have also included versions of QMR without look-ahead. In particular, there is code for "QMR from BCG", which generates QMR by simply adding one extra SAXPY to each BCG iteration. However, in view of their enhanced stability, we recommend the use of the "true" QMR methods with look-ahead. The package also contains a no-look-ahead version of TFQMR, which is a transpose-free variant of QMR. The package comes with two preconditioners: SSOR and a variant of Youcef Saad's ILUT preconditioner. Finally, the package also includes code for computing eigenvalues of nonsymmetric matrices, using the look-ahead Lanczos algorithm. X ------ X X December 31, 1991 X General Info ------------ X This is the final version of the double precision real Lanczos/QMR codes. It is a major rewrite of the previous version. The strategy used to update the QMR iterate has been changed considerably, and the SVD is no longer used to invert the diagonal blocks, as it resulted in too much roundoff being introduced. On the other hand, the code still does not reuse already computed matrix-vector products when blocks are rebuilt. When a block is rebuilt, the matrix-vector products spent in the discarded portion at the end of the block are wasted. In theory, it is possible to reuse these matrix-vector products, so that N steps of the algorithm require exactly N multiplications by A and A^T each. While we know how this would be done, implementing it robustly is a major headache and we deemed the gains to be insignificant (read: too lazy to do this). X As promised, this release does contain a QMR/BCG code which generates the existing BCG iterates stably from the QMR process; see the makefile options for the corresponding entries. X The distribution consists of FORTRAN files in several subdirectories. The code is actually not standard FORTRAN; one has to run the C preprocessor on the individual files to obtain FORTRAN-77 code. This is done so that we could code easier, in that various pieces of the work arrays are given macro names, resulting in code that says, for example, X X CALL AXB (_V_(N), _V_(N+1)) X rather than the FORTRAN version X X CALL AXB (VW(1,Q(N)), VW(1,Q(N+1))) X We'd rather work with the former! Some compilers, such as the Sun compiler, automatically run the C preprocessor on the input file, if it has the extension .F (rather than the default .f extension). In any case, the makefiles provided are set up to run the C preprocessor `cpp' on the .F files to produce standard .f files. Other than having to correctly specify in the `skeleton.mak' file the path to the C preprocessor, this should be transparent to you. If you run into problems, let us know, and we can send you the plain FORTRAN files. X Once you have unpacked the distribution (by now that should be done), you are ready to solve systems in the formats provided, or you may add your own formats. On a Sun-4 running SunOS v4.0 (and possibly on others as well), the makefile should help you get started. You can type `make help' or simply `make', and it will list its options. To compile the package on other systems, you might have to change the names and/or directories for some of the programs used by the makefile (see the "Various programs..." section of skeleton.mak). The current skeleton.mak file is set up for our (possibly non-standard) system setup (f77 in /usr/lang, cpp in /lib, etc). As an example, on the Cray-2 here at NASA Ames, the following settings apply: X CPP = /lib/cpp FC = /bin/cf77 FFLAGS = X The current version of the codes is listed in the file version.h. Minor bug fixes and modifications will be available as diffs relative to the files in a standard distribution, so you might want to keep an original copy around. Please always reference the version number whenever you have a question or comment about the codes. X In this day and age, some legalese is necessary, so here it goes. Please note that the codes are copyrighted. This was done for two purposes: first, we want to make sure that you (and your lawyers!) understand that we do not warrant these codes to do anything at all. We are distributing them for free, and think they don't do anything whatsoever. For all intent and purpose, any description of what the codes are doing should be construed as being a note of what we thought the codes did on our machine on a particular Tuesday of last year. They might do the same thing again someday, and then again they might not (and, if history is any indication, they probably won't). Having said that, the second purpose is that we have nevertheless invested time and energy in these codes, and while we do not mind you using them for research, we do not want you selling them. So, if you want to make any profit from these codes, you have to have our permission. You are certainly allowed to use the codes for your own research. You are also allowed to distribute the codes, as long as you do not charge for this more than the cost of the media and a reasonable handling fee; an example of what we mean by ``reasonable'' is something not more than three times the current U.S. minimum wage (around $5/hr in 1991). But you are not allowed to sell any part of these codes, either alone or incorporated in some product you might design. You are, of course, welcome to code up your own versions of these codes. X Otherwise, we would be interested in hearing about your experience with the codes, especially bugs (what bugs?), smashing success stories, and stunning failures. We can be contacted at na.freund@na-net.ornl.gov (Roland Freund) and na.nachtigal@na-net.ornl.gov (Noel Nachtigal). Also note that we make no claims about the support codes. For example, the ILUT routine is not particularly efficient; it did the job for us, and we did not spend any time improving it. Finally, if you use these codes in your research, please reference one or the other of the following technical reports, as appropriate: X (For eigenvalue computations) Roland W. Freund, Martin H. Gutknecht, and Noel M. Nachtigal. An Implementation of the Look-Ahead Lanczos Algorithm for Non-Hermitian Matrices. Technical Report 91.09, RIACS, NASA Ames Research Center, April 1991. To appear in the SIAM Journal on Statistical and Scientific Computing. X (For linear systems -- QMR) Roland W. Freund and Noel M. Nachtigal. QMR: a Quasi-Minimal Residual Method for Non-Hermitian Linear System. Technical Report 90.51, RIACS, NASA Ames Research Center, December 1990. To appear in Numerische Mathematik. X In case you wish to find out more about how the codes work, the following references describe it in some detail: X (For the heuristics used in the eigenvalue computations) Jane Cullum and Ralph A. Willoughby. A Practical Procedure for Computing Eigenvalues of Large Sparse Nonsymmetric Matrices. In Large Scale Eigenvalue Problems (J. Cullum and R.A. Willoughby, eds), North-Holland, 1986, pp.193--240. X (For a description of the Harwell-Boeing format) I.S. Duff, R.G Grimes, and J.G. Lewis. Sparse Matrix Test Problems. ACM Transactions of Mathematical Software, vol 15, 1989, pp. 1--14. X (For the basic implementation of the look-ahead Lanczos algorithm) Roland W. Freund, Martin H. Gutknecht, and Noel M. Nachtigal. An Implementation of the Look-Ahead Lanczos Algorithm for Non-Hermitian Matrices, Part I. Technical Report 90.45, RIACS, NASA Ames Research Center, November 1990. X (For the QMR algorithm) Roland W. Freund and Noel M. Nachtigal. An Implementation of the Look-Ahead Lanczos Algorithm for Non-Hermitian Matrices, Part II. Technical Report 90.46, RIACS, NASA Ames Research Center, November 1990. X Roland W. Freund and Noel M. Nachtigal. QMR: a Quasi-Minimal Residual Method for Non-Hermitian Linear System. Technical Report 90.51, RIACS, NASA Ames Research Center, December 1990. X (For a description of the SPARSKIT package) Youcef Saad. SPARSKIT: a Basic Tool Kit for Sparse Matrix Computations. Technical Report 90.20, RIACS, NASA Ames Research Center, May 1990. X Finally, the codes in the sup directory are support routines required from the LINPACK and EISPACK libraries. These should be replaced with the local copies of the libraries. In addition, the DNRM2 routine from the linpack.f file has a DATA statement which follows the variable declaration. This is not standard FORTRAN and some compilers might complain about it. We did not modify it ourselves, since the routine was taken from the LINPACK library. X X An Example ---------- X OK. Suppose now you want to solve a system. We have provided two as examples, a small 3x3 dense system to indicate how dense matrices are stored, and an example in Harwell-Boeing format. To solve the example Harwell-Boeing system, type `make scsr', then, when the compilation completes, type `dsys' and answer the prompts as follows (your answers are denoted with `<=='): X Enter sparse data file name: dat/csr.dat <== NDIM : 250 NZMAX : 1500 JOB : 2 NRHS : 0 GUESOL: NROW : 225 NCOL : 225 NNZ : 1065 TITLE : 7-POINT TEST MATRIX FROM SPARSKIT KEY : rua TYPE : 7-P IERR : 0 Enter estimated matrix norm : 1.0e3 <== Enter convergence tolerance : 1.0e-6 <== Maximum number of steps NLIM : 65 <== Preconditioner: ILUT Precondition (1=Yes, 0=No) ? 0 <== X We ran this example on a Sun-4 and on a pair of Crays (Cray-2 and Cray YMP). The results for the Sun-4 were: X 1 1 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+04 X 2 1 0.1145E+01 0.8705E+00 0.9874E-01 0.1000E+04 X 3 1 0.1402E+01 0.8691E+00 0.6632E-01 0.1000E+04 X 4 1 0.1590E+01 0.8258E+00 0.2191E-01 0.1000E+04 X 5 1 0.1750E+01 0.7988E+00 0.1657E-01 0.1000E+04 X 6 1 0.1887E+01 0.7921E+00 0.1473E-02 0.1000E+04 X 7 1 0.2032E+01 0.7572E+00 0.1525E-02 0.1000E+04 X 8 1 0.2131E+01 0.7577E+00 0.1317E-01 0.1000E+04 X 9 1 0.2156E+01 0.7355E+00 0.1040E-01 0.1000E+04 X 10 1 0.2233E+01 0.7715E+00 0.8337E-02 0.1000E+04 X 11 1 0.2313E+01 0.7937E+00 0.7020E-02 0.1000E+04 X 12 1 0.2379E+01 0.8358E+00 0.7696E-02 0.1000E+04 X 13 1 0.2475E+01 0.8313E+00 0.1887E-02 0.1000E+04 X 14 1 0.2542E+01 0.8907E+00 0.4649E-02 0.1000E+04 X 15 1 0.2629E+01 0.8819E+00 0.2295E-02 0.1000E+04 X 16 1 0.2697E+01 0.8950E+00 0.4872E-02 0.1000E+04 X 17 1 0.2775E+01 0.9051E+00 0.1411E-02 0.1000E+04 X 18 1 0.2838E+01 0.9258E+00 0.1398E-01 0.1000E+04 X 19 1 0.2901E+01 0.9417E+00 0.1173E-02 0.1000E+04 X 20 1 0.2949E+01 0.9872E+00 0.3449E-02 0.1000E+04 X 21 1 0.2995E+01 0.1035E+01 0.1433E-02 0.1000E+04 X 22 1 0.3041E+01 0.1089E+01 0.2032E-02 0.1000E+04 X 23 1 0.3082E+01 0.1144E+01 0.5925E-02 0.1000E+04 X 24 1 0.3113E+01 0.1205E+01 0.1884E-02 0.1000E+04 X 25 1 0.3010E+01 0.1079E+01 0.2231E-02 0.1000E+04 X 26 1 0.2773E+01 0.9390E+00 0.1533E-01 0.1000E+04 X 27 1 0.2444E+01 0.6838E+00 0.1130E-01 0.1000E+04 X 28 1 0.2409E+01 0.6322E+00 0.2135E-01 0.1000E+04 X 29 1 0.2452E+01 0.6323E+00 0.2038E-01 0.1000E+04 X 30 1 0.2059E+01 0.4352E+00 0.4548E-02 0.1000E+04 X 31 1 0.2006E+01 0.3896E+00 0.3308E-06 0.1000E+04 X 32 1 0.1323E+01 0.2407E+00 0.1692E-06 0.1000E+04 X 33 1 0.1335E+01 0.2222E+00 0.6722E-06 0.1000E+04 X 34 1 0.1336E+01 0.1932E+00 0.7657E-08 0.1000E+04 X 35 1 0.1354E+01 0.1985E+00 0.4373E-08 0.1000E+04 X 36 1 0.1370E+01 0.2062E+00 0.2437E-09 0.1000E+04 X 37 1 0.1389E+01 0.2047E+00 0.2836E-09 0.1000E+04 X 38 1 0.1390E+01 0.1935E+00 0.2421E-08 0.1000E+04 X 39 1 0.1323E+01 0.1399E+00 0.8416E-09 0.1000E+04 X 40 1 0.1340E+01 0.1398E+00 0.3249E-08 0.1000E+04 X 41 1 0.1356E+01 0.1397E+00 0.2340E-09 0.1000E+04 X 42 1 0.1303E+01 0.1370E+00 0.3690E-09 0.1000E+04 X 43 1 0.1141E+01 0.1609E+00 0.1123E-08 0.1000E+04 X 44 1 0.1142E+01 0.1783E+00 0.4717E-09 0.1000E+04 X 45 1 0.1008E+01 0.1986E+00 0.2442E-09 0.1000E+04 X 46 1 0.3137E+00 0.3047E-01 0.5367E-09 0.1000E+04 X 47 1 0.2382E+00 0.3412E-01 0.3704E-08 0.1000E+04 X 48 1 0.9779E-01 0.1188E-01 0.7983E-09 0.1000E+04 X 49 1 0.9109E-01 0.1374E-01 0.3691E-08 0.1000E+04 X 50 1 0.5057E-01 0.1008E-01 0.3673E-09 0.1000E+04 X 51 1 0.1005E-01 0.1499E-02 0.5906E-09 0.1000E+04 X 52 1 0.5223E-02 0.3446E-03 0.4439E-08 0.1000E+04 X 53 1 0.1170E-03 0.1614E-04 0.3954E-08 0.1000E+04 X 54 1 0.7184E-04 0.1322E-04 0.1412E-06 0.1000E+04 X 55 1 0.8707E-05 0.1349E-05 0.2749E-06 0.1000E+04 X 56 1 0.6942E-05 0.1346E-05 0.2776E-05 0.1000E+04 X 57 1 0.5192E-05 0.1097E-05 0.2473E-05 0.1000E+04 X 58 1 0.8281E-06 0.1321E-06 0.4710E-06 0.1000E+04 The residual norm has converged. Play it again (Y/N) ? n <== X The results for both Crays were: X 1 1 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+04 X 2 1 0.1145E+01 0.8705E+00 0.9874E-01 0.1000E+04 X 3 1 0.1402E+01 0.8691E+00 0.6632E-01 0.1000E+04 X 4 1 0.1590E+01 0.8258E+00 0.2191E-01 0.1000E+04 X 5 1 0.1750E+01 0.7988E+00 0.1657E-01 0.1000E+04 X 6 1 0.1887E+01 0.7921E+00 0.1473E-02 0.1000E+04 X 7 1 0.2032E+01 0.7572E+00 0.1525E-02 0.1000E+04 X 8 1 0.2131E+01 0.7577E+00 0.1317E-01 0.1000E+04 X 9 1 0.2156E+01 0.7355E+00 0.1040E-01 0.1000E+04 X 10 1 0.2233E+01 0.7715E+00 0.8337E-02 0.1000E+04 X 11 1 0.2313E+01 0.7937E+00 0.7020E-02 0.1000E+04 X 12 1 0.2379E+01 0.8358E+00 0.7696E-02 0.1000E+04 X 13 1 0.2475E+01 0.8313E+00 0.1887E-02 0.1000E+04 X 14 1 0.2542E+01 0.8907E+00 0.4649E-02 0.1000E+04 X 15 1 0.2629E+01 0.8819E+00 0.2295E-02 0.1000E+04 X 16 1 0.2697E+01 0.8950E+00 0.4872E-02 0.1000E+04 X 17 1 0.2775E+01 0.9051E+00 0.1411E-02 0.1000E+04 X 18 1 0.2838E+01 0.9258E+00 0.1398E-01 0.1000E+04 X 19 1 0.2901E+01 0.9417E+00 0.1173E-02 0.1000E+04 X 20 1 0.2949E+01 0.9872E+00 0.3449E-02 0.1000E+04 X 21 1 0.2995E+01 0.1035E+01 0.1433E-02 0.1000E+04 X 22 1 0.3041E+01 0.1089E+01 0.2032E-02 0.1000E+04 X 23 1 0.3082E+01 0.1144E+01 0.5925E-02 0.1000E+04 X 24 1 0.3113E+01 0.1205E+01 0.1884E-02 0.1000E+04 X 25 1 0.3010E+01 0.1079E+01 0.2231E-02 0.1000E+04 X 26 1 0.2773E+01 0.9390E+00 0.1533E-01 0.1000E+04 X 27 1 0.2444E+01 0.6838E+00 0.1130E-01 0.1000E+04 X 28 1 0.2409E+01 0.6322E+00 0.2135E-01 0.1000E+04 X 29 1 0.2452E+01 0.6323E+00 0.2038E-01 0.1000E+04 X 30 1 0.2059E+01 0.4352E+00 0.4548E-02 0.1000E+04 X 31 1 0.2006E+01 0.3896E+00 0.3308E-06 0.1000E+04 X 32 1 0.1323E+01 0.2407E+00 0.1692E-06 0.1000E+04 X 33 1 0.1335E+01 0.2222E+00 0.6722E-06 0.1000E+04 X 34 1 0.1336E+01 0.1932E+00 0.7657E-08 0.1000E+04 X 35 1 0.1354E+01 0.1985E+00 0.4373E-08 0.1000E+04 X 36 1 0.1370E+01 0.2062E+00 0.2437E-09 0.1000E+04 X 37 1 0.1389E+01 0.2047E+00 0.2836E-09 0.1000E+04 X 38 1 0.1390E+01 0.1935E+00 0.2421E-08 0.1000E+04 X 39 1 0.1323E+01 0.1399E+00 0.8416E-09 0.1000E+04 X 40 1 0.1340E+01 0.1398E+00 0.3249E-08 0.1000E+04 X 41 1 0.1356E+01 0.1397E+00 0.2340E-09 0.1000E+04 X 42 1 0.1303E+01 0.1370E+00 0.3690E-09 0.1000E+04 X 43 1 0.1141E+01 0.1609E+00 0.1123E-08 0.1000E+04 X 44 1 0.1142E+01 0.1783E+00 0.4717E-09 0.1000E+04 X 45 1 0.1008E+01 0.1986E+00 0.2442E-09 0.1000E+04 X 46 1 0.3136E+00 0.3047E-01 0.5367E-09 0.1000E+04 X 47 1 0.2382E+00 0.3412E-01 0.3704E-08 0.1000E+04 X 48 1 0.9779E-01 0.1188E-01 0.7984E-09 0.1000E+04 X 49 1 0.9109E-01 0.1374E-01 0.3691E-08 0.1000E+04 X 50 1 0.5057E-01 0.1008E-01 0.3673E-09 0.1000E+04 X 51 1 0.1005E-01 0.1499E-02 0.5906E-09 0.1000E+04 X 52 1 0.5222E-02 0.3446E-03 0.4439E-08 0.1000E+04 X 53 1 0.1167E-03 0.1611E-04 0.3954E-08 0.1000E+04 X 54 1 0.7310E-04 0.1350E-04 0.1437E-06 0.1000E+04 X 55 1 0.9228E-05 0.1436E-05 0.2661E-06 0.1000E+04 X 56 1 0.7685E-05 0.1361E-05 0.2075E-05 0.1000E+04 X 57 1 0.3302E-05 0.5971E-06 0.7132E-06 0.1000E+04 The residual norm has converged. Play it again (Y/N) ? n <== X In both cases, the exact solution is the vector of all 1's. You can check the solution returned in the file `x.out' and see how it compares. That's it. To solve bigger systems, you will need to adjust the parameters in `dsys.f', `dimblk.inc', and `csr.inc', but the basic idea remains the same. For the dense system provided in the subdirectory `dns', the exact solution is X X 4.441959994855718e+01 X -3.071517860902447e+02 X -1.857585177589905e+02 X 6.304596860549932e+01 X 7.078107514016136e+02 X 2.004530083313206e+02 X -1.133227360733343e+01 X -3.541347098296361e+02 X 4.374106238114270e+02 X -2.400890005920496e+02 X -3.911009425579379e+02 X -2.798321395307324e+01 X -2.918743864606955e+01 X 1.117419236671314e+01 X -1.145266987648990e+02 X 2.823876794263498e+02 X 3.625516005161455e+01 X -4.460202949059404e+01 X -1.039938190024286e+02 X -1.653064614588225e+02 X It is left as an exercise to the reader to set up and solve the dense linear system. For eigenvalues, use `make ecsr' for Harwell-Boeing matrices, `make edns' for dense matrices. Remember that for eigenvalues, you will eventually be solving an eigenvalue problem whose size equals the number of steps taken, so don't get carried away... X X Changes history --------------- X X Version Comments X 1.0 Initial release X 1.1 Corrected bugs reported by Claude Pommerell (pommy@iis.ethz.ch) X in dsys.f, dlal.f, dsyslal.f X 1.2 Corrected bugs reported by Marlis Hochbruck (marlis@riacs.edu) X in dlal.f. X Changed the SVD tolerance from 0 to eps in deiglal.f, dsyslal.f X Changed the initial norm estimation in dlal.f X 1.3 Corrected bug in dlal.f X 1.4 Updated the README and makefile files X Cleaned up the daxbpr.f file X 1.5 Corrected bugs reported by Eric Lucas @ Westinghouse X 2.0 Final release, new strategy for QMR update, switched from SVD X to QR X Distribution Tree for version 2 ------------------------------- X Below is a listing of the distribution tree, with explanations for each of the subdirectories. X The main distribution directory: total 59 -rw-rw-rw- 1 santa 22816 Dec 31 08:00 README drwxrwxrwx 2 santa 512 Dec 31 08:00 bru/ drwxrwxrwx 2 santa 1024 Dec 31 08:00 csr/ drwxrwxrwx 2 santa 512 Dec 31 08:00 dat/ drwxrwxrwx 2 santa 512 Dec 31 08:00 dns/ drwxrwxrwx 2 santa 512 Dec 31 08:00 inc/ drwxrwxrwx 2 santa 1024 Dec 31 08:00 lal/ -rw-rw-rw- 1 santa 959 Dec 31 08:00 local.mak -rw-rw-rw- 1 santa 5212 Dec 31 08:00 makefile -rw-rw-rw- 1 santa 2412 Dec 31 08:00 skeleton.mak drwxrwxrwx 2 santa 512 Dec 31 08:00 sup/ -rw-rw-rw- 2 santa 5850 Dec 31 08:00 v.dat -rw-rw-rw- 1 santa 20 Dec 31 08:00 version.h -rw-rw-rw- 2 santa 5850 Dec 31 08:00 w.dat -rw-rw-rw- 2 santa 5400 Dec 31 08:00 x.dat X This directory contains example codes for a matrix-free problem. `daxb.f' has the code for the matrix-vector routines, and `daxbpr.f' has the code for the preconditioner routines (which in this example are empty). bru: total 17 -rw-rw-rw- 1 santa 770 Dec 31 08:00 axb.inc -rw-rw-rw- 1 santa 1579 Dec 31 08:00 cpyrit.doc -rw-rw-rw- 1 santa 9536 Dec 31 08:00 daxb.F -rw-rw-rw- 1 santa 2013 Dec 31 08:00 daxbpr.F -rw-rw-rw- 1 santa 1077 Dec 31 08:00 makefile X This directory contains support routines for the Harwell-Boeing format. `dcsr.f' contains the main matrix-vector routines (some taken from SPARSKIT), `sparskit.f' contains the remaining support routines from SPARSKIT. The remaining files contain routines for various preconditioners. csr: total 73 -rw-rw-rw- 1 santa 1579 Dec 31 08:00 cpyrit.doc -rw-rw-rw- 1 santa 999 Dec 31 08:00 csr.inc -rw-rw-rw- 1 santa 8640 Dec 31 08:00 dcilut.F -rw-rw-rw- 1 santa 7610 Dec 31 08:00 dclilut.F -rw-rw-rw- 1 santa 6513 Dec 31 08:00 dclssor.F -rw-rw-rw- 1 santa 7610 Dec 31 08:00 dcrilut.F -rw-rw-rw- 1 santa 6521 Dec 31 08:00 dcrssor.F -rw-rw-rw- 1 santa 10293 Dec 31 08:00 dcsr.F -rw-rw-rw- 1 santa 9872 Dec 31 08:00 ilut.F -rw-rw-rw- 1 santa 2638 Dec 31 08:00 makefile -rw-rw-rw- 1 santa 6422 Dec 31 08:00 sparskit.F X This directory contains example data files for the matrices. `dns.dat' has the data for the 3x3 matrix X A = [ 1 2 3; 5 7 11; 13 17 19 ], while `csr.dat' contains the data for a sparse routine in Harwell-Boeing format. The other files are the right-hand sides (`csrv.dat' and `dnsv.dat'), the second starting vector (`csrw.dat' and `dnsw.dat'), and the starting guess (`csrx.dat' for both). dat: total 59 -rw-rw-rw- 1 santa 29298 Dec 31 08:00 csr.dat -rw-rw-rw- 2 santa 5850 Dec 31 08:00 csrv.dat -rw-rw-rw- 2 santa 5850 Dec 31 08:00 csrw.dat -rw-rw-rw- 2 santa 5400 Dec 31 08:00 csrx.dat -rw-rw-rw- 1 santa 9603 Dec 31 08:00 dns.dat -rw-rw-rw- 2 santa 480 Dec 31 08:00 dnsv.dat -rw-rw-rw- 2 santa 480 Dec 31 08:00 dnsw.dat X This directory contains support routines for the dense format. 'ddns.f' has the main matrix-vector routines, while the remaining files contain routines for various preconditioners. dns: total 24 -rw-rw-rw- 1 santa 1579 Dec 31 08:00 cpyrit.doc -rw-rw-rw- 1 santa 5671 Dec 31 08:00 ddlssor.F -rw-rw-rw- 1 santa 6294 Dec 31 08:00 ddns.F -rw-rw-rw- 1 santa 5575 Dec 31 08:00 ddrssor.F -rw-rw-rw- 1 santa 750 Dec 31 08:00 dns.inc -rw-rw-rw- 1 santa 1600 Dec 31 08:00 makefile X This directory contains the main include files which govern the maximum dimension of the matrix (`dimblk.inc') and the common block declaration for the preconditioner name. All other files `dimblk.inc' and `precon.inc' (there is a pair in every other subdirectory) are linked to these two. inc: total 2 -rw-rw-rw- 1 santa 224 Dec 31 08:00 dimblk.inc -rw-rw-rw- 1 santa 155 Dec 31 08:00 precon.inc X This is the directory which contains the Lanczos routines. `dlal.f' is the main low-level Lanczos routine; it calls `dcoeff.f'. For linear systems, `dsys.f' is the example driver code, which calls the QMR routines `dsyslal.f', which in turn calls `dlal.f' and `getomg.f'. For eigenvalues, `deig.f' is the example driver code, which calls `deiglal.f', which in turn calls `dlal.f'. lal: total 127 -rw-rw-rw- 1 santa 1579 Dec 31 08:00 cpyrit.doc -rw-rw-rw- 1 santa 2725 Dec 31 08:00 dcoeff.F -rw-rw-rw- 1 santa 13813 Dec 31 08:00 deig.F -rw-rw-rw- 1 santa 13177 Dec 31 08:00 deiglal.F -rw-rw-rw- 1 santa 23494 Dec 31 08:00 dlal.F -rw-rw-rw- 1 santa 1597 Dec 31 08:00 dlal.inc -rw-rw-rw- 1 santa 8607 Dec 31 08:00 dsys.F -rw-rw-rw- 1 santa 28685 Dec 31 08:00 dsysbcg.F -rw-rw-rw- 1 santa 26481 Dec 31 08:00 dsyslal.F -rw-rw-rw- 1 santa 1266 Dec 31 08:00 getomg.F -rw-rw-rw- 1 santa 1502 Dec 31 08:00 makefile X This directory contains miscellaneous support routines from EISPACK, LINPACK, and a sorting routine in `support.f'. sup: total 87 -rw-rw-rw- 1 santa 1558 Dec 31 08:00 cpyrit.doc -rw-rw-rw- 1 santa 38090 Dec 31 08:00 eispack.f -rw-rw-rw- 1 santa 42496 Dec 31 08:00 linpack.f -rw-rw-rw- 1 santa 1016 Dec 31 08:00 makefile -rw-rw-rw- 1 santa 3728 Dec 31 08:00 support.f SHAR_EOF chmod 0600 dble/README || echo 'restore of dble/README failed' Wc_c="`wc -c < 'dble/README'`" test 24247 -eq "$Wc_c" || echo 'dble/README: original size 24247, current size' "$Wc_c" fi # ============= dble/makefile ============== if test -f 'dble/makefile' -a X"$1" != X"-c"; then echo 'x - skipping dble/makefile (File already exists)' else echo 'x - extracting dble/makefile (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/makefile' && #********************************************************************** # # Copyright (C) 1991 Roland W. Freund and Noel M. Nachtigal # All rights reserved. # # This code is part of a copyrighted package. For details, see the # file `cpyrit.doc' in the `lal' directory. # # ***************************************************************** # ANY USE OF THIS CODE CONSTITUES ACCEPTANCE OF THE TERMS OF THE # COPYRIGHT NOTICE # ***************************************************************** # #********************************************************************** X # # NOTE: GNU make seems to choke and gag on this makefile. # include skeleton.mak X # # Various compilation directories. # DIRS = bru csr dns lal sup AXB = bru X # # Files included in the distribution package. # TOP = dble REL = $(TOP)/README $(TOP)/bcg $(TOP)/bru $(TOP)/csr $(TOP)/dat $(TOP)/dns $(TOP)/gmr $(TOP)/grc $(TOP)/inc $(TOP)/lal $(TOP)/makefile $(TOP)/sup $(TOP)/*.dat $(TOP)/*.mak X # # This is the local help target. # lochelp: X @$(ECHO) " noout - remove output files" X @$(ECHO) " rel - make the release tar file" X @$(ECHO) " " X @$(ECHO) " baxb - generic format, QMR/BCG" X @$(ECHO) " bcsr - compressed sparse row format, QMR/BCG" X @$(ECHO) " bdns - dense format, QMR/BCG" X @$(ECHO) " eaxb - generic format, Lanczos, ew's" X @$(ECHO) " ecsr - compressed sparse row format, Lanczos, ew's" X @$(ECHO) " edns - dense format, Lanczos, ew's" X @$(ECHO) " saxb - generic format, QMR" X @$(ECHO) " scsr - compressed sparse row format, QMR" X @$(ECHO) " sdns - dense format, QMR" X FEIG = eaxb ecsr edns FLIN = baxb bcsr bdns caxb ccsr cdns gaxb gcsr gdns saxb scsr sdns X # # for - make all FORTRAN files # nofor - remove all FORTRAN files # obj - make all object files # noobj - remove all object files # for nofor obj noobj: X @( \ X for f in $(DIRS); \ X do $(CD) $$f; \ X $(MAKE) $@; \ X $(CD) ..; \ X done ) X # # none - remove everything # none: noout X @( \ X for f in $(DIRS); \ X do $(CD) $$f; \ X $(MAKE) nofor noobj; \ X $(CD) ..; \ X done ) X # # Remove all output files. # noout: X @$(RM) $(RMFLAGS) $(FEIG) $(FLIN) deig dsys *.out X # # Distribution files. # rel: nofor noobj X @( \ X $(CD) ..; \ X $(RM) $(RMFLAGS) $(TOP).T; \ X $(ECHO) Copying release files; \ X $(TAR) cFFhf $(TOP).T $(REL); \ X $(ECHO) Compressing the tar file; \ X $(COMPRESS) $(TOP).T; \ X $(MV) $(MVFLAGS) $(TOP).T.Z $(TOP) ) X # # The generic format, Lanczos-QMR/BCG, linear systems. # BAXBF = $(AXB)/daxb.o $(AXB)/daxbpr.o lal/dcoeff.o lal/dsys.o lal/dsysbcg.o \ X lal/dlal.o lal/getomg.o sup/linpack.o sup/support.o baxb: obj X @$(FC) -o dsys $(FFLAGS) $(LDFLAGS) $(BAXBF) X @$(RM) $(RMFLAGS) $(FLIN) X @$(ECHO) " " > baxb X # # The generic format, Lanczos, eigenvalues. # EAXBF = $(AXB)/daxb.o $(AXB)/daxbpr.o lal/dcoeff.o lal/deig.o lal/deiglal.o \ X lal/dlal.o sup/eispack.o sup/linpack.o sup/support.o eaxb: obj X @$(FC) -o deig $(FFLAGS) $(LDFLAGS) $(EAXBF) X @$(RM) $(RMFLAGS) $(FEIG) X @$(ECHO) " " > eaxb X # # The generic format, Lanczos-QMR, linear systems. # SAXBF = $(AXB)/daxb.o $(AXB)/daxbpr.o lal/dcoeff.o lal/dsys.o lal/dsyslal.o \ X lal/dlal.o lal/getomg.o sup/linpack.o sup/support.o saxb: obj X @$(FC) -o dsys $(FFLAGS) $(LDFLAGS) $(SAXBF) X @$(RM) $(RMFLAGS) $(FLIN) X @$(ECHO) " " > saxb X # # The compressed sparse row (CSR) format, Lanczos-QMR/BCG, linear systems. # BCSRF = csr/dcsr.o csr/dcsrpr.o csr/ilut.o csr/sparskit.o lal/dcoeff.o \ X lal/dsys.o lal/dsysbcg.o lal/dlal.o lal/getomg.o sup/linpack.o \ X sup/support.o bcsr: obj X @$(FC) -o dsys $(FFLAGS) $(LDFLAGS) $(BCSRF) X @$(RM) $(RMFLAGS) $(FLIN) X # # The compressed sparse row (CSR) format, Lanczos, eigenvalues. # ECSRF = csr/dcsr.o csr/dcsrpr.o csr/sparskit.o lal/dcoeff.o lal/deig.o \ X lal/deiglal.o lal/dlal.o sup/eispack.o csr/ilut.o sup/linpack.o \ X sup/support.o ecsr: obj X @$(FC) -o deig $(FFLAGS) $(LDFLAGS) $(ECSRF) X @$(RM) $(RMFLAGS) $(FEIG) X @$(ECHO) " " > ecsr X # # The compressed sparse row (CSR) format, Lanczos-QMR, linear systems. # SCSRF = csr/dcsr.o csr/dcsrpr.o csr/ilut.o csr/sparskit.o lal/dcoeff.o \ X lal/dsys.o lal/dsyslal.o lal/dlal.o lal/getomg.o sup/linpack.o \ X sup/support.o scsr: obj X @$(FC) -o dsys $(FFLAGS) $(LDFLAGS) $(SCSRF) X @$(RM) $(RMFLAGS) $(FLIN) X @$(ECHO) " " > scsr X # # The dense (DNS) format, Lanczos-QMR/BCG, linear systems. # BDNSF = dns/ddns.o dns/ddnspr.o lal/dcoeff.o lal/dsys.o lal/dsysbcg.o \ X lal/dlal.o lal/getomg.o sup/linpack.o sup/support.o bdns: obj X @$(FC) -o dsys $(FFLAGS) $(LDFLAGS) $(BDNSF) X @$(RM) $(RMFLAGS) $(FLIN) X @$(ECHO) " " > bdns X # # The dense (DNS) format, Lanczos, eigenvalues. # EDNSF = dns/ddns.o dns/ddnspr.o lal/dcoeff.o lal/deig.o lal/deiglal.o \ X lal/dlal.o sup/eispack.o sup/linpack.o sup/support.o edns: obj X @$(FC) -o deig $(FFLAGS) $(LDFLAGS) $(EDNSF) X @$(RM) $(RMFLAGS) $(FEIG) X @$(ECHO) " " > edns X # # The dense (DNS) format, Lanczos-QMR, linear systems. # SDNSF = dns/ddns.o dns/ddnspr.o lal/dcoeff.o lal/dsys.o lal/dsyslal.o \ X lal/dlal.o lal/getomg.o sup/linpack.o sup/support.o sdns: obj X @$(FC) -o dsys $(FFLAGS) $(LDFLAGS) $(SDNSF) X @$(RM) $(RMFLAGS) $(FLIN) X @$(ECHO) " " > sdns SHAR_EOF chmod 0600 dble/makefile || echo 'restore of dble/makefile failed' Wc_c="`wc -c < 'dble/makefile'`" test 5212 -eq "$Wc_c" || echo 'dble/makefile: original size 5212, current size' "$Wc_c" fi # ============= dble/v.dat ============== if test -f 'dble/v.dat' -a X"$1" != X"-c"; then echo 'x - skipping dble/v.dat (File already exists)' else echo 'x - extracting dble/v.dat (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/v.dat' && X 0.17265625000000000E+01 X 0.66796875000000000E+00 X 0.66796875000000000E+00 X 0.66796875000000000E+00 X 0.66796875000000000E+00 X 0.66796875000000000E+00 X 0.66796875000000000E+00 X 0.66796875000000000E+00 X 0.66796875000000000E+00 X 0.66796875000000000E+00 X 0.66796875000000000E+00 X 0.66796875000000000E+00 X 0.66796875000000000E+00 X 0.66796875000000000E+00 X 0.78906250000000000E+00 X 0.66796875000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.26953125000000000E+00 X 0.66796875000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.26953125000000000E+00 X 0.66796875000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.26953125000000000E+00 X 0.66796875000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.26953125000000000E+00 X 0.66796875000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.26953125000000000E+00 X 0.66796875000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.26953125000000000E+00 X 0.66796875000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.26953125000000000E+00 X 0.66796875000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.26953125000000000E+00 X 0.66796875000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.26953125000000000E+00 X 0.66796875000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.26953125000000000E+00 X 0.66796875000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.26953125000000000E+00 X 0.66796875000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.26953125000000000E+00 X 0.66796875000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.26953125000000000E+00 X 0.78906250000000000E+00 X -0.26953125000000000E+00 X -0.26953125000000000E+00 X -0.26953125000000000E+00 X -0.26953125000000000E+00 X -0.26953125000000000E+00 X -0.26953125000000000E+00 X -0.26953125000000000E+00 X -0.26953125000000000E+00 X -0.26953125000000000E+00 X -0.26953125000000000E+00 X -0.26953125000000000E+00 X -0.26953125000000000E+00 X -0.26953125000000000E+00 X -0.14843750000000000E+00 SHAR_EOF chmod 0600 dble/v.dat || echo 'restore of dble/v.dat failed' Wc_c="`wc -c < 'dble/v.dat'`" test 5850 -eq "$Wc_c" || echo 'dble/v.dat: original size 5850, current size' "$Wc_c" fi # ============= dble/w.dat ============== if test -f 'dble/w.dat' -a X"$1" != X"-c"; then echo 'x - skipping dble/w.dat (File already exists)' else echo 'x - extracting dble/w.dat (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/w.dat' && X -2.52670612285392693e+00 X -3.12981492764229430e-01 X -5.93617618531314117e-01 X 3.32322161717665654e-01 X 5.58850703293451434e-01 X 8.99883573546131688e-01 X -2.00898855586523289e-01 X -2.33734974678243862e-01 X 1.44990660185244824e+00 X 1.83613202602166203e+00 X -3.82918259160919427e-01 X 1.55082744517634041e-01 X -9.64648249056895501e-01 X 3.87564312898231872e-02 X 7.65458387074111402e-01 X -5.94524007839467128e-01 X 1.30245975190897978e-01 X 3.50135051326026445e-02 X -6.24674138678893653e-01 X -5.39775240747623841e-01 X 1.87995711256766906e+00 X -1.00384945408178328e+00 X -4.97445877674741299e-01 X -1.50439715265068541e+00 X -9.54492989363980443e-02 X 3.96727053727293111e-01 X -5.27114907886174100e-01 X 3.44571055586827601e-01 X -7.23290526415817259e-01 X 1.26819336319292564e+00 X -3.12426582958191153e-02 X 7.78211737167248230e-01 X 2.18048355295766028e+00 X 4.37813681537625787e-01 X 1.33332898358725349e+00 X 2.51078139110859744e-01 X -3.10470908178119731e-01 X -9.23003723808715093e-01 X -3.84775736018752812e-01 X 1.15818057089115922e+00 X 8.62500188414089375e-01 X -1.03470562492749885e+00 X -1.92672883298641989e-01 X -1.29972277987506701e+00 X 3.06595916028863658e-01 X 9.68992176157492779e-01 X -7.47317126758189398e-01 X -2.79602442297918508e+00 X 6.96731553587481622e-01 X 3.20690754366444031e+00 X 5.36007044749823192e-01 X 2.98450535720106380e-01 X 2.84043160995206323e-01 X 9.59664371348601719e-01 X 2.08759311209632337e+00 X 1.52468053170777473e+00 X -1.95260790032330211e-01 X 1.72603158008979921e-02 X 2.46340438601763606e-01 X -8.54484721089849630e-01 X 1.15778270176474307e+00 X 1.61907723250136332e-01 X 1.55706375548542164e+00 X -1.93543855158581107e-01 X 1.65130117445043179e+00 X -1.89877818089584816e+00 X 1.82252476317014889e+00 X -1.51841513419531315e+00 X -1.05107060879933423e+00 X 4.99305134332340902e-02 X -1.45474886952808413e+00 X 4.66545849753955855e-01 X 5.45436841452860643e-01 X 1.32031907308504048e+00 X -4.04494327876404325e-01 X 4.18468509073848915e-01 X 2.47348749631457726e-01 X 7.04110315408186027e-01 X 6.31938853341632800e-01 X -9.92362112719314848e-01 X 1.76670836879512128e+00 X -3.82103635072939263e-01 X -9.11425420031350630e-01 X -9.96089984118210370e-01 X 1.19514263014411903e+00 X -1.59447782443430802e-01 X 2.70402604824876036e+00 X -1.98499915965496987e-01 X -1.41404614026417491e-01 X 4.11267926557380703e-01 X -1.17905965667048696e+00 X -2.77775505971886494e-01 X -1.58105341380234377e+00 X 1.04902234978445863e+00 X 3.02689036171394199e-01 X -1.22650234105829847e+00 X 6.96000950977379157e-02 X -3.96516210293235416e-01 X 1.38880676152053462e+00 X 1.36442229049003072e+00 X 6.58152637292665821e-01 X 4.91313668926088520e-01 X 8.00733701087079197e-01 X -7.67268996676585435e-01 X 3.64419504046212817e-01 X -3.97913854767016573e-01 X 8.64279576409737516e-01 X -1.77618078276664149e-01 X 1.87438052046940795e+00 X 1.72400234691113430e-01 X 1.27174349438397227e+00 X -3.53443679957601356e-02 X -1.50132883642183579e+00 X 3.65373411191592334e-01 X -1.98659856001020180e-01 X -1.38972170325750999e+00 X 2.29327812227314215e-01 X 2.71190236967230214e-01 X -3.66360220282281213e-01 X 1.37696039157049333e+00 X -7.97532756562797762e-01 X -9.36740611780525367e-01 X -2.43346548885311044e-03 X 3.96086165525257827e-01 X -5.08693172275514027e-01 X -2.68285778746197690e-01 X -1.08214045362096933e+00 X 2.01413372029120419e+00 X 1.94403112557593682e+00 X -1.52152941634797623e+00 X 1.93931842629591666e+00 X -8.95840360657292223e-01 X -3.04157582743064425e-01 X 5.55253123177883778e-01 X -3.24246850701504052e-01 X 1.33881436714640256e+00 X 1.22229851347237273e+00 X -1.59597816278255955e+00 X -1.06773032044442528e+00 X -7.59919212299574154e-01 X 4.20988804468648503e-01 X -4.33373058325242422e-01 X 7.06251990240337246e-01 X 2.27856907314768625e-01 X -1.01699185125668268e+00 X 1.39860372563678254e-01 X -7.48088838235888787e-01 X -6.28974933137321557e-01 X 1.39483065417114704e+00 X -1.64769114004944095e+00 X -2.01498584386620427e+00 X 4.91716880786256527e-01 X -1.55497527509081546e+00 X -1.40609080683032323e-01 X 2.44943668795265301e-01 X -2.67458499968963315e-01 X -5.70245479900343022e-01 X -1.87266786888367814e-01 X 1.20855664796684303e+00 X -6.38854660397775276e-01 X 6.05540298516074937e-01 X -6.24480544088507727e-01 X 5.72228121730056660e-01 X -7.24410495952223288e-01 X 1.19219550553089348e+00 X 1.86746737068575697e-01 X 1.59493888226368430e+00 X 3.21307055691724686e-01 X 8.66840733181726275e-01 X 1.29184357610291878e+00 X 4.34312653452442632e-01 X -3.86206929335472016e-01 X -1.12563759811723021e-01 X -9.64333079249251268e-01 X -2.05725119297093961e+00 X 1.49996068326108345e-01 X 5.42037570810973812e-01 X 2.54408816480612421e-01 X -3.07240693819984811e-01 X -4.17111829581745308e-01 X 1.13680483289389689e+00 X 3.91313809093234544e-01 X 1.60514781867489997e+00 X 8.25892307356857591e-01 X 1.47039035572010768e+00 X -1.37890689233989572e+00 X -2.60172069009687479e-01 X 9.94768172763982217e-01 X 1.83403368186402838e+00 X -1.71591031873495248e+00 X 8.69317058746622712e-02 X 1.95567435281059465e+00 X 1.61453769615341497e-01 X -6.28688359125363805e-01 X -1.43882446533843478e+00 X -6.65959685875582436e-02 X 3.73380862806065694e-01 X 2.17314078186247150e-01 X -1.79456822070788363e-01 X 2.56729070095519964e-02 X 6.42066361973081534e-01 X 9.23086649379001090e-01 X -1.55510777372327769e+00 X 6.63594032788892285e-01 X -6.09499611051491308e-01 X 5.65239403309624411e-01 X -6.10781446255285299e-01 X 1.23111146649210634e+00 X 9.94299745127406931e-01 X -8.03474713644618865e-01 X -5.91204478397532762e-01 X 1.69154640779536125e+00 X 9.53355517329613988e-01 X -1.93005493739851142e+00 X 5.12844987283965770e-01 X 3.93682448572880705e-01 X -9.05426500446262272e-01 X -1.27447327679614819e+00 X 3.46546103379725356e-01 X -1.19523544023497297e+00 X 6.67201442318699822e-01 X -6.77937745985269097e-02 X -1.73566010510706481e+00 X 8.06348573332824392e-01 X -9.14800737775520956e-01 SHAR_EOF chmod 0600 dble/w.dat || echo 'restore of dble/w.dat failed' Wc_c="`wc -c < 'dble/w.dat'`" test 5850 -eq "$Wc_c" || echo 'dble/w.dat: original size 5850, current size' "$Wc_c" fi # ============= dble/local.mak ============== if test -f 'dble/local.mak' -a X"$1" != X"-c"; then echo 'x - skipping dble/local.mak (File already exists)' else echo 'x - extracting dble/local.mak (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/local.mak' && #********************************************************************** # # Copyright (C) 1991 Roland W. Freund and Noel M. Nachtigal # All rights reserved. # # This code is part of a copyrighted package. For details, see the # file `cpyrit.doc' in the `lal' directory. # # ***************************************************************** # ANY USE OF THIS CODE CONSTITUES ACCEPTANCE OF THE TERMS OF THE # COPYRIGHT NOTICE # ***************************************************************** # #********************************************************************** # # Additional skeleton for the local makefiles. # X # # Make all auxiliary files. # for: $(FOR) $(INC) X # # Clean up auxiliary files. # nofor: X @$(RM) $(RMFLAGS) $(FOR) $(INC) X # # Make all object files. # obj: $(OBJ) X # # Clean up object files. # noobj: X @$(RM) $(RMFLAGS) $(OBJ) X # # Clean up everything. # none: nofor noobj SHAR_EOF chmod 0600 dble/local.mak || echo 'restore of dble/local.mak failed' Wc_c="`wc -c < 'dble/local.mak'`" test 959 -eq "$Wc_c" || echo 'dble/local.mak: original size 959, current size' "$Wc_c" fi # ============= dble/skeleton.mak ============== if test -f 'dble/skeleton.mak' -a X"$1" != X"-c"; then echo 'x - skipping dble/skeleton.mak (File already exists)' else echo 'x - extracting dble/skeleton.mak (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/skeleton.mak' && #********************************************************************** # # Copyright (C) 1991 Roland W. Freund and Noel M. Nachtigal # All rights reserved. # # This code is part of a copyrighted package. For details, see the # file `cpyrit.doc' in the `lal' directory. # # ***************************************************************** # ANY USE OF THIS CODE CONSTITUES ACCEPTANCE OF THE TERMS OF THE # COPYRIGHT NOTICE # ***************************************************************** # #********************************************************************** # # Skeleton for all the makefiles. # X # # Make our own suffixes' list. # .SUFFIXES: .SUFFIXES: .f .o .SUFFIXES: .F .f X # # Default command. # .DEFAULT: X @$(ECHO) "Unknown target $@, try: make help" X # # Command to build .o files from .f files. # .f.o: X @$(ECHO) Making $@ from $< X @$(FC) -c $(FFLAGS) $< X .F.f: X @$(ECHO) Making $@ from $< X @$(CPP) -P $(CPPFLAGS) $< $@ X # # Various compilation programs and flags. # You need to make sure these are correct for your system. # CD = cd X CHMOD = chmod CHFLAGS = -f X COMPRESS = compress X CP = cp X # To find the path for cpp, try `man cpp', and it should list the path # at the top, under `Syntax'. It is usually in /lib. CPP = /lib/cpp CPPFLAGS = X ECHO = echo X # You also need to adjust the path to your FORTRAN compiler. FC = /usr/lang/f77 FFLAGS = X LDFLAGS = X LN = ln LNFLAGS = -s X MAKE = /bin/make X MKDIR = mkdir MDFLAGS = -p X MV = mv MVFLAGS = -f X RM = rm RMFLAGS = -f X SHELL = /bin/sh X TAR = tar X # # Default target is help. # help: genhelp lochelp X # # Dependencies for include files in all directories. # cpyrit.inc: ../inc/cpyrit.inc X @$(LN) $(LNFLAGS) $? $@ X dimblk.inc: ../inc/dimblk.inc X @$(LN) $(LNFLAGS) $? $@ X precon.inc: ../inc/precon.inc X @$(LN) $(LNFLAGS) $? $@ X # # This is the general help target. In the individual makefiles, one must # put a `lochelp' target, which may list additional help. The `lochelp' # target must exist even if it is merely a dummy. # genhelp: X @$(ECHO) "usage: make fmt" X @$(ECHO) " where fmt is one of:" X @$(ECHO) " for - make all auxiliary FORTRAN files" X @$(ECHO) " obj - make all object files" X @$(ECHO) " nofor - remove auxiliary FORTRAN files" X @$(ECHO) " noobj - remove object files" X @$(ECHO) " none - remove everything" SHAR_EOF chmod 0600 dble/skeleton.mak || echo 'restore of dble/skeleton.mak failed' Wc_c="`wc -c < 'dble/skeleton.mak'`" test 2412 -eq "$Wc_c" || echo 'dble/skeleton.mak: original size 2412, current size' "$Wc_c" fi # ============= dble/x.dat ============== if test -f 'dble/x.dat' -a X"$1" != X"-c"; then echo 'x - skipping dble/x.dat (File already exists)' else echo 'x - extracting dble/x.dat (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/x.dat' && X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 SHAR_EOF chmod 0600 dble/x.dat || echo 'restore of dble/x.dat failed' Wc_c="`wc -c < 'dble/x.dat'`" test 5400 -eq "$Wc_c" || echo 'dble/x.dat: original size 5400, current size' "$Wc_c" fi # ============= dble/version.h ============== if test -f 'dble/version.h' -a X"$1" != X"-c"; then echo 'x - skipping dble/version.h (File already exists)' else echo 'x - extracting dble/version.h (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/version.h' && #define VERSION 2.0 SHAR_EOF chmod 0600 dble/version.h || echo 'restore of dble/version.h failed' Wc_c="`wc -c < 'dble/version.h'`" test 20 -eq "$Wc_c" || echo 'dble/version.h: original size 20, current size' "$Wc_c" fi # ============= dble/bru/axb.inc ============== if test ! -d 'dble/bru'; then echo 'x - creating directory dble/bru' mkdir 'dble/bru' fi if test -f 'dble/bru/axb.inc' -a X"$1" != X"-c"; then echo 'x - skipping dble/bru/axb.inc (File already exists)' else echo 'x - extracting dble/bru/axb.inc (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/bru/axb.inc' && C********************************************************************** C C Copyright (C) 1991 Roland W. Freund and Noel M. Nachtigal C All rights reserved. C C This code is part of a copyrighted package. For details, see the C file `cpyrit.doc' in the current directory. C C ***************************************************************** C ANY USE OF THIS CODE CONSTITUES ACCEPTANCE OF THE TERMS OF THE C COPYRIGHT NOTICE C ***************************************************************** C C********************************************************************** C C Common block ABLK. C X INTEGER INIT X DOUBLE PRECISION C1, C2, C3, D1, D2, D3 X COMMON /ABLK/C1, C2, C3, D1, D2, D3, INIT SHAR_EOF chmod 0600 dble/bru/axb.inc || echo 'restore of dble/bru/axb.inc failed' Wc_c="`wc -c < 'dble/bru/axb.inc'`" test 770 -eq "$Wc_c" || echo 'dble/bru/axb.inc: original size 770, current size' "$Wc_c" fi # ============= dble/bru/cpyrit.doc ============== if test -f 'dble/bru/cpyrit.doc' -a X"$1" != X"-c"; then echo 'x - skipping dble/bru/cpyrit.doc (File already exists)' else echo 'x - extracting dble/bru/cpyrit.doc (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/bru/cpyrit.doc' && C********************************************************************** C C Copyright (C) 1991 Roland W. Freund and Noel M. Nachtigal C All rights reserved. C C This code is provided "as is", without any warranty of any kind, C either expressed or implied, including but not limited to, any C implied warranty of merchantibility or fitness for any purpose. C In no event will any party who distributed the code be liable for C damages or for any claim(s) by any other party, including but not C limited to, any lost profits, lost monies, lost data or data C rendered inaccurate, losses sustained by third parties, or any C other special, incidental or consequential damages arising out of C the use or inability to use the program, even if the possibility C of such damages has been advised against. The entire risk as to C the quality, the performance, and the fitness of the program for C any particular purpose lies with the party using the code. C C No derivative of this code may be used in a commercial package C without the prior explicit written permission of all authors or C their legal proxies. Verbatim copies of this code may be made and C distributed in any medium, provided that this copyright notice C is not removed or altered in any way. No fees may be charged for C distribution of the codes, other than a fee to cover the cost of C the media and a reasonable handling fee. C C********************************************************************** SHAR_EOF chmod 0600 dble/bru/cpyrit.doc || echo 'restore of dble/bru/cpyrit.doc failed' Wc_c="`wc -c < 'dble/bru/cpyrit.doc'`" test 1579 -eq "$Wc_c" || echo 'dble/bru/cpyrit.doc: original size 1579, current size' "$Wc_c" fi # ============= dble/bru/daxb.f ============== if test -f 'dble/bru/daxb.f' -a X"$1" != X"-c"; then echo 'x - skipping dble/bru/daxb.f (File already exists)' else echo 'x - extracting dble/bru/daxb.f (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/bru/daxb.f' && C********************************************************************** C C Copyright (C) 1991 Roland W. Freund and Noel M. Nachtigal C All rights reserved. C C This code is part of a copyrighted package. For details, see the C file `cpyrit.doc' in the current directory. C C ***************************************************************** C ANY USE OF THIS CODE CONSTITUES ACCEPTANCE OF THE TERMS OF THE C COPYRIGHT NOTICE C ***************************************************************** C C********************************************************************** C C This file contains support routines for the Brusselator problem C used to test the eigenvalue codes. The following routines are in C this file: C C SUBROUTINE AXB (X,B) C Computes B = A * X. C SUBROUTINE ATXB (X,B) C Computes B = A^T * X. C SUBROUTINE EXACT (WR,WI) C Computes the exact eigenvalues of the Brusselator matrix. C SUBROUTINE GETMAT C Initializes the data for the Brusselator matrix. C DOUBLE PRECISION FUNCTION GETNRM() C Returns an estimate for the norm of the matrix based on using C Gershgorin disks. C C********************************************************************** C X SUBROUTINE AXB (X,B) C C Purpose: C This subroutine computes B = A * X for the Brusselator matrix. C For more info on this, see Rascham et al., "Waves in distributed C chemical systems: experiments and computations", published in C `New approaches to nonlinear problems in Dynamics', Ed P. Holmes, C SIAM Pub., 1980, pp. 271-288. See also B.N. Parlett and Y. Saad, C _Complex shift and invert strategies for real matrices_, Linear C Algebra Appl. 88/89 (1987), pp. 575-595. C C Parameters: C X = the vector to be multiplied by A (input). C B = the result of the multiplication (output). C C Noel M. Nachtigal C October 2, 1990 C X DOUBLE PRECISION B(*), X(*) C X INCLUDE 'dimblk.inc' X INCLUDE 'axb.inc' C C Local variables. C X INTEGER I, J, NHALF X DOUBLE PRECISION CTMP, DTMP C C Set up the multiplication. C X CTMP = C2 - 2.0 * C1 X DTMP = D3 - 2.0 * D1 X NHALF = NROW / 2 C C Now do the multiplication. First, the main body. C X DO 10 I = 2, NHALF - 1 X J = I + NHALF X B(I) = CTMP * X(I) + C1 * ( X(I+1) + X(I-1) ) + X $ C3 * X(J) X B(J) = DTMP * X(J) + D1 * ( X(J+1) + X(J-1) ) + X $ D2 * X(I) X 10 CONTINUE C C Then, the exceptional cases. C X I = 1 X J = NHALF + 1 X B(I) = CTMP * X(I) + C1 * X(I+1) + C3 * X(J) X B(J) = DTMP * X(J) + D1 * X(J+1) + D2 * X(I) C X I = NHALF X J = NROW X B(I) = CTMP * X(I) + C1 * X(I-1) + C3 * X(J) X B(J) = DTMP * X(J) + D1 * X(J-1) + D2 * X(I) C X RETURN X END C C********************************************************************** C X SUBROUTINE ATXB (X,B) C C Purpose: C This subroutine computes B = A^T * X for the Brusselator matrix. C C Parameters: C X = the vector to be multiplied by A (input). C B = the result of the multiplication (output). C C Noel M. Nachtigal C October 2, 1990 C X DOUBLE PRECISION B(*), X(*) C X INCLUDE 'dimblk.inc' X INCLUDE 'axb.inc' C C Local variables. C X INTEGER I, J, NHALF X DOUBLE PRECISION CTMP, DTMP C C Set up the multiplication. C X CTMP = C2 - 2.0 * C1 X DTMP = D3 - 2.0 * D1 X NHALF = NROW / 2 C C Now do the multiplication. First, the main body. C X DO 10 I = 2, NHALF - 1 X J = I + NHALF X B(I) = CTMP * X(I) + C1 * ( X(I+1) + X(I-1) ) + X $ D2 * X(J) X B(J) = DTMP * X(J) + D1 * ( X(J+1) + X(J-1) ) + X $ C3 * X(I) X 10 CONTINUE C C Then, the exceptional cases. C X I = 1 X J = NHALF + 1 X B(I) = CTMP * X(I) + C1 * X(I+1) + D2 * X(J) X B(J) = DTMP * X(J) + D1 * X(J+1) + C3 * X(I) C X I = NHALF X J = NROW X B(I) = CTMP * X(I) + C1 * X(I-1) + D2 * X(J) X B(J) = DTMP * X(J) + D1 * X(J-1) + C3 * X(I) C X RETURN X END C C********************************************************************** C X SUBROUTINE EXACT (WR,WI) C C Purpose: C This subroutine computes the exact eigenvalues of the Brusselator C matrix. C C Parameters: C WR = contains on output the real parts (output). C WI = contains on output the imaginary parts (output). C C Noel M. Nachtigal C October 2, 1990 C X INTRINSIC ABS, FLOAT, SIN, SQRT C X DOUBLE PRECISION WR(*), WI(*) C X INCLUDE 'dimblk.inc' X INCLUDE 'axb.inc' C C Local variables. C X DOUBLE PRECISION PI X PARAMETER (PI=3.141592653589793238462643383279D0) C X INTEGER I, J X DOUBLE PRECISION XI, XMU, XN, S, S1, S2, T C C Initialize some data. C X J = 0 X XN = 0.5 / FLOAT( NROW / 2 + 1 ) C C Compute the eigenvalues -- they always come in pairs. C X DO 10 I = 1, NROW / 2 X XI = PI * FLOAT(I) X XMU = -( 2.0 * SIN(XI * XN) )**2.0 X S1 = C1*XMU + C2 X S2 = D1*XMU + D3 X S = 0.5 * (S1 + S2) X T = D2*C3 + 0.25 * (S1 - S2)**2 X IF (T.GE.0.0) THEN C C This is the real case. C X T = SQRT(ABS(T)) X J = J+1 X WR(J) = S+T X WI(J) = 0.0 X J = J+1 X WR(J) = S-T X WI(J) = 0.0 X ELSE C C This is the complex case. C X T = SQRT(ABS(T)) X J = J+1 X WR(J) = S X WI(J) = T X J = J+1 X WR(J) = S X WI(J) = -T X ENDIF X 10 CONTINUE C X RETURN X END C C********************************************************************** C X SUBROUTINE GETMAT C C Purpose: C This subroutine initializes the Brusselator matrix by reading its C control parameters from the user. C C External routines used: C subroutine exact(wr,wi) C Computes the exact eigenvalues of the Brusselator matrix. C subroutine hsort(n,x,y) C Sorts arrays x and y based on x. C C Noel M. Nachtigal C October 2, 1990 C X INTRINSIC FLOAT C X INCLUDE 'dimblk.inc' X INCLUDE 'axb.inc' C C Local variables. C X CHARACTER*1 ANS X INTEGER I X DOUBLE PRECISION A, B, DX, DY, H, TMP, WR(NDIM), WI(NDIM), XL C C Initialize the variables to defaults. C X NCOL = 200 X NROW = 200 X DX = 0.00800 X DY = 0.00400 X A = 2.00000 X B = 5.45000 X XL = 0.51302 C C Get the data from the user. C X WRITE (6,'(A31,$)') 'Enter the dimension N (200) : ' X READ (5,*) NROW X NCOL = 2 * ( NROW / 2 ) X IF (NCOL.NE.NROW) THEN X WRITE (6,'(A32,I10)') 'N must be even - truncated to: ', NCOL X ENDIF C WRITE (6,'(A31,$)') 'Enter the spacing DX (0.008) : ' C READ (5,*) DX C WRITE (6,'(A31,$)') 'Enter the spacing DY (0.004) : ' C READ (5,*) DY C WRITE (6,'(A31,$)') 'Enter the constant A (2.0) : ' C READ (5,*) A C WRITE (6,'(A31,$)') 'Enter the constant B (5.45) : ' C READ (5,*) B C WRITE (6,'(A31,$)') 'Enter XL (0.51302) : ' C READ (5,*) XL C C Compute the matrix entries. C X NROW = NCOL / 2 X H = 1.0 / (FLOAT(NROW + 1)) X TMP = ( H * XL )**2 X C1 = DX / TMP X D1 = DY / TMP X C2 = B - 1.0 X D2 = -B X C3 = A**2 X D3 = -A**2 X NROW = NCOL C C Output the matrix parameters. C X WRITE (6,'(A5,E25.18)') 'C1 : ', C1 X WRITE (6,'(A5,E25.18)') 'C2 : ', C2 X WRITE (6,'(A5,E25.18)') 'C3 : ', C3 X WRITE (6,'(A5,E25.18)') 'D1 : ', D1 X WRITE (6,'(A5,E25.18)') 'D2 : ', D2 X WRITE (6,'(A5,E25.18)') 'D3 : ', D3 C C Check that it isn't too big. C X IF (NCOL.GT.NDIM) THEN X WRITE (6,'(A36)') 'Matrix dimension exceeds allocation.' X STOP X ENDIF C C Optionally output the exact eigenvalues. C X WRITE (6,'(A37,$)') 'Output the exact eigenvalues (Y/N) ? ' X READ (5,'(A1)') ANS X IF ((ANS.EQ.'Y').OR.(ANS.EQ.'y')) THEN X CALL EXACT (WR,WI) X CALL HSORT (NROW,WR,WI) X OPEN (10,FILE='exact.out') X DO 10 I = 1, NROW X WRITE (10,'(2E30.18)') WR(I), WI(I) X 10 CONTINUE X CLOSE (10) X ENDIF C C Set the initialized flag. C X INIT = 1 C X RETURN X END C C********************************************************************** C X DOUBLE PRECISION FUNCTION GETNRM() C C Purpose: C This function returns an estimate for the norm of the matrix. The C current estimate is based on Gershgorin disks. C C Noel M. Nachtigal C October 2, 1990 C X INTRINSIC MAX, MIN C X INCLUDE 'dimblk.inc' X INCLUDE 'axb.inc' C C Local variables. C X DOUBLE PRECISION DTMP1, DTMP2, DTMP3 C C Get the maximum column norm. C X DTMP2 = 2.0 * ABS(C1) + ABS(C2 - 2.0*C1) + ABS(D2) X DTMP3 = 2.0 * ABS(D1) + ABS(D3 - 2.0*D1) + ABS(C3) X DTMP1 = MAX(DTMP2,DTMP3) C C Get the maximum row norm. C X DTMP2 = 2.0 * ABS(C1) + ABS(C2 - 2.0*C1) + ABS(C3) X DTMP3 = 2.0 * ABS(D1) + ABS(D3 - 2.0*D1) + ABS(D2) X DTMP2 = MAX(DTMP2,DTMP3) C C Get the smallest of the two. C X GETNRM = MIN(DTMP1,DTMP2) C X RETURN X END C C********************************************************************** SHAR_EOF chmod 0600 dble/bru/daxb.f || echo 'restore of dble/bru/daxb.f failed' Wc_c="`wc -c < 'dble/bru/daxb.f'`" test 9536 -eq "$Wc_c" || echo 'dble/bru/daxb.f: original size 9536, current size' "$Wc_c" fi # ============= dble/bru/daxbpr.f ============== if test -f 'dble/bru/daxbpr.f' -a X"$1" != X"-c"; then echo 'x - skipping dble/bru/daxbpr.f (File already exists)' else echo 'x - extracting dble/bru/daxbpr.f (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/bru/daxbpr.f' && C********************************************************************** C C Copyright (C) 1991 Roland W. Freund and Noel M. Nachtigal C All rights reserved. C C This code is part of a copyrighted package. For details, see the C file `cpyrit.doc' in the current directory. C C ***************************************************************** C ANY USE OF THIS CODE CONSTITUES ACCEPTANCE OF THE TERMS OF THE C COPYRIGHT NOTICE C ***************************************************************** C C********************************************************************** C C These are dummy preconditioner routines. C C There are four routines: C M1I (X,Y) - empty; C M1T (X,Y) - empty; C M2I (X,Y) - empty; C M2T (X,Y) - empty; C PSETUP - empty; C C Noel M. Nachtigal C January 13, 1991 C C********************************************************************** C X SUBROUTINE M1I(X,Y) C X DOUBLE PRECISION X(*), Y(*) C X RETURN X END C C********************************************************************** C X SUBROUTINE M1T(X,Y) C X DOUBLE PRECISION X(*), Y(*) C X RETURN X END C C********************************************************************** C X SUBROUTINE M2I(X,Y) C X DOUBLE PRECISION X(*), Y(*) C X RETURN X END C C********************************************************************** C X SUBROUTINE M2T(X,Y) C X DOUBLE PRECISION X(*), Y(*) C X RETURN X END C C********************************************************************** C X SUBROUTINE PSETUP C X RETURN X END C C********************************************************************** C X BLOCK DATA C C Purpose: C This sets the preconditioner name to 'NONE'. C C Noel M. Nachtigal C January 13, 1991 C X INCLUDE 'precon.inc' C X DATA PNAME/'NONE'/ C X END C C********************************************************************** SHAR_EOF chmod 0600 dble/bru/daxbpr.f || echo 'restore of dble/bru/daxbpr.f failed' Wc_c="`wc -c < 'dble/bru/daxbpr.f'`" test 2013 -eq "$Wc_c" || echo 'dble/bru/daxbpr.f: original size 2013, current size' "$Wc_c" fi # ============= dble/bru/makefile ============== if test -f 'dble/bru/makefile' -a X"$1" != X"-c"; then echo 'x - skipping dble/bru/makefile (File already exists)' else echo 'x - extracting dble/bru/makefile (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/bru/makefile' && #********************************************************************** # # Copyright (C) 1991 Roland W. Freund and Noel M. Nachtigal # All rights reserved. # # This code is part of a copyrighted package. For details, see the # file `cpyrit.doc' in the current directory. # # ***************************************************************** # ANY USE OF THIS CODE CONSTITUES ACCEPTANCE OF THE TERMS OF THE # COPYRIGHT NOTICE # ***************************************************************** # #********************************************************************** # # Makefile for the Brusselator matrix subdirectory. # # Files in this directory: # INC = dimblk.inc precon.inc FOR = OBJ = daxb.o daxbpr.o SRC = daxb.f daxbpr.f axb.inc X # # Include here the skeleton makefile. # include ../skeleton.mak include ../local.mak X # # This is the local help target. # lochelp: X # # Dependencies for files in this directory. # daxb.o: daxb.f axb.inc dimblk.inc X daxbpr.o: daxbpr.f axb.inc dimblk.inc precon.inc SHAR_EOF chmod 0600 dble/bru/makefile || echo 'restore of dble/bru/makefile failed' Wc_c="`wc -c < 'dble/bru/makefile'`" test 1077 -eq "$Wc_c" || echo 'dble/bru/makefile: original size 1077, current size' "$Wc_c" fi # ============= dble/csr/cpyrit.doc ============== if test ! -d 'dble/csr'; then echo 'x - creating directory dble/csr' mkdir 'dble/csr' fi if test -f 'dble/csr/cpyrit.doc' -a X"$1" != X"-c"; then echo 'x - skipping dble/csr/cpyrit.doc (File already exists)' else echo 'x - extracting dble/csr/cpyrit.doc (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/csr/cpyrit.doc' && C********************************************************************** C C Copyright (C) 1991 Roland W. Freund and Noel M. Nachtigal C All rights reserved. C C This code is provided "as is", without any warranty of any kind, C either expressed or implied, including but not limited to, any C implied warranty of merchantibility or fitness for any purpose. C In no event will any party who distributed the code be liable for C damages or for any claim(s) by any other party, including but not C limited to, any lost profits, lost monies, lost data or data C rendered inaccurate, losses sustained by third parties, or any C other special, incidental or consequential damages arising out of C the use or inability to use the program, even if the possibility C of such damages has been advised against. The entire risk as to C the quality, the performance, and the fitness of the program for C any particular purpose lies with the party using the code. C C No derivative of this code may be used in a commercial package C without the prior explicit written permission of all authors or C their legal proxies. Verbatim copies of this code may be made and C distributed in any medium, provided that this copyright notice C is not removed or altered in any way. No fees may be charged for C distribution of the codes, other than a fee to cover the cost of C the media and a reasonable handling fee. C C********************************************************************** SHAR_EOF chmod 0600 dble/csr/cpyrit.doc || echo 'restore of dble/csr/cpyrit.doc failed' Wc_c="`wc -c < 'dble/csr/cpyrit.doc'`" test 1579 -eq "$Wc_c" || echo 'dble/csr/cpyrit.doc: original size 1579, current size' "$Wc_c" fi # ============= dble/csr/csr.inc ============== if test -f 'dble/csr/csr.inc' -a X"$1" != X"-c"; then echo 'x - skipping dble/csr/csr.inc (File already exists)' else echo 'x - extracting dble/csr/csr.inc (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/csr/csr.inc' && C********************************************************************** C C Copyright (C) 1991 Roland W. Freund and Noel M. Nachtigal C All rights reserved. C C This code is part of a copyrighted package. For details, see the C file `cpyrit.doc' in the current directory. C C ***************************************************************** C ANY USE OF THIS CODE CONSTITUES ACCEPTANCE OF THE TERMS OF THE C COPYRIGHT NOTICE C ***************************************************************** C C********************************************************************** C C Common block ABLK. C X INTEGER NZMAX X PARAMETER (NZMAX=1500) C X INTEGER IA(NDIM+1), ILU(NDIM+1), JA(NZMAX), JLU(NZMAX) X INTEGER IDA(NDIM), ITMP(NDIM) X DOUBLE PRECISION A(NZMAX), LU(NZMAX), AINV(NDIM) X DOUBLE PRECISION DN(NDIM), DR(NDIM), XTMP(NDIM) X COMMON /ABLK/A, LU, AINV, DN, DR, XTMP, IA, JA, ILU, JLU, IDA, X $ ITMP SHAR_EOF chmod 0600 dble/csr/csr.inc || echo 'restore of dble/csr/csr.inc failed' Wc_c="`wc -c < 'dble/csr/csr.inc'`" test 999 -eq "$Wc_c" || echo 'dble/csr/csr.inc: original size 999, current size' "$Wc_c" fi # ============= dble/csr/dcilut.f ============== if test -f 'dble/csr/dcilut.f' -a X"$1" != X"-c"; then echo 'x - skipping dble/csr/dcilut.f (File already exists)' else echo 'x - extracting dble/csr/dcilut.f (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/csr/dcilut.f' && C********************************************************************** C C Copyright (C) 1991 Roland W. Freund and Noel M. Nachtigal C All rights reserved. C C This code is part of a copyrighted package. For details, see the C file `cpyrit.doc' in the current directory. C C ***************************************************************** C ANY USE OF THIS CODE CONSTITUES ACCEPTANCE OF THE TERMS OF THE C COPYRIGHT NOTICE C ***************************************************************** C C********************************************************************** C C These are the preconditioner routines for the ILUT preconditioner C applied to sparse matrices. C C There are five routines: C M1I (X,Y) - computes X = M_1^{-1} * X, Y a work vector; C M1T (X,Y) - computes X = M_1^{-T} * X, Y a work vector; C M2I (X,Y) - computes X = M_2^{-1} * X, Y a work vector; C M2T (X,Y) - computes X = M_2^{-T} * X, Y a work vector; C PSETUP - sets up the ILUT preconditioner. C C For the ILUT preconditioner, C M = M_1 * M_2 = L * U. C where C M_1 = L, M_2 = U. C C Noel M. Nachtigal C November 23, 1990 C C********************************************************************** C X SUBROUTINE M1I (X,Y) C C Purpose: C Computes X = M_1^{-1} * X. In the case of ILUT, M_1 is L, a lower C triangular matrix with 1's on the diagonal, stored in row major C order. Hence, the elimination is formulated as dot products of C rows of L with the upper parts of X. C C Parameters: C X = the vector to apply the preconditioner to (input/output). C Y = work vector (output). C C Noel M. Nachtigal C October 31, 1990 C X DOUBLE PRECISION X(*), Y(*) C X INCLUDE 'dimblk.inc' X INCLUDE 'csr.inc' C C Local variables. C X INTEGER I, J, K X DOUBLE PRECISION DTMP C C Loop over the rows. C X DO 20 I = 1, NROW X DTMP = 0.0 C C Loop over the columns, up to the diagonal. C X DO 10 K = ILU(I), IDA(I)-1 X J = JLU(K) X DTMP = DTMP + LU(K) * X(J) X 10 CONTINUE C C Compute X(I). L(I,I) = 1.0. C X X(I) = X(I) - DTMP C X 20 CONTINUE C X RETURN X END C C********************************************************************** C X SUBROUTINE M1T (X,Y) C C Purpose: C Computes X = M_1^{-T} * X. In the case of ILUT, M_1 is L, a lower C triangular matrix with 1's on the diagonal, stored in row major C order. Hence, the elimination is formulated as sums of columns of C L^T (i.e., rows of L), subtracted from the corresponding parts of C X. C C Parameters: C X = the vector to apply the preconditioner to (input/output). C Y = work vector (output). C C Noel M. Nachtigal C October 31, 1990 C X DOUBLE PRECISION X(*), Y(*) C X INCLUDE 'dimblk.inc' X INCLUDE 'csr.inc' C C Local variables. C X INTEGER I, J, K X DOUBLE PRECISION DTMP C C Loop over the columns of L^T. C X DO 20 I = NROW, 1, -1 C C We already have X(I), since L(I,I) = 1. Subtract the next column. C X DTMP = X(I) X DO 10 K = ILU(I), IDA(I)-1 X J = JLU(K) X X(J) = X(J) - DTMP * LU(K) X 10 CONTINUE X 20 CONTINUE C X RETURN X END C C********************************************************************** C X SUBROUTINE M2I (X,Y) C C Purpose: C Computes X = M_2^{-1} * X. In the case of ILUT, M_2 is U, a upper C triangular matrix, stored in row major order. The elimination is C formulated as dot products of rows of U with the lower parts of C X. C C Parameters: C X = the vector to apply the preconditioner to (input/output). C Y = work vector (output). C C Noel M. Nachtigal C October 31, 1990 C X DOUBLE PRECISION X(*), Y(*) C X INCLUDE 'dimblk.inc' X INCLUDE 'csr.inc' C C Local variables. C X INTEGER I, J, K X DOUBLE PRECISION DTMP C C Loop over the rows. C X DO 20 I = NROW, 1, -1 X DTMP = 0.0 X DO 10 K = IDA(I)+1, ILU(I+1)-1 X J = JLU(K) X DTMP = DTMP + LU(K) * X(J) X 10 CONTINUE C C Compute X(I). LU(IDA(I)) = 1.0 / U(I,I). C X X(I) = ( X(I) - DTMP ) * LU(IDA(I)) C X 20 CONTINUE C X RETURN X END C C********************************************************************** C X SUBROUTINE M2T (X,Y) C C Purpose: C Computes X = M_2^{-T} * X. In the case of ILUT, M_2 is U, a upper C triangular matrix, stored in row major order. The elimination is C formulated as sums of solumns of U^T (i.e., rows of U) subtracted C from the corresponding parts of X. C C Parameters: C X = the vector to apply the preconditioner to (input/output). C Y = work vector (output). C C Noel M. Nachtigal C October 31, 1990 C X DOUBLE PRECISION X(*), Y(*) C X INCLUDE 'dimblk.inc' X INCLUDE 'csr.inc' C C Local variables. C X INTEGER I, J, K X DOUBLE PRECISION DTMP C C Loop over the column of U^T. C X DO 20 I = 1, NROW C C Compute X(I). LU(IDA(I)) = 1.0 / U(I,I). C X X(I) = X(I) * LU(IDA(I)) C C Subtract the next column. C X DTMP = X(I) X DO 10 K = IDA(I)+1, ILU(I+1)-1 X J = JLU(K) X X(J) = X(J) - DTMP * LU(K) X 10 CONTINUE X 20 CONTINUE C X RETURN X END C C********************************************************************** C X SUBROUTINE PSETUP C C Purpose: C This subroutine sets up the preconditioner. It assumes that the C global arrays A, IA, JA give the matrix in CSR format, and LU, C ILU, and JLU give the matrix in CSC format (transposed). We also C check for small diagonals, where small is relative to the 1-norm C of the row and the column. If a small diagonal element is found, C PRECON is set to -1. C C External routines used: C double precision dadd(dx,dy) C Computes dx + dy. Used to get around optimizers. C double precision dasum(n,dx,incx) C Computes the 1-norm of dx. C C Noel M. Nachtigal C October 31, 1990 C X INTRINSIC MAX X EXTERNAL DADD, DASUM X DOUBLE PRECISION DADD, DASUM C X INCLUDE 'dimblk.inc' X INCLUDE 'csr.inc' C C Local variables. C X INTEGER FILL, I, J, K X DOUBLE PRECISION DNRM, DTMP, TOL C C Compute the 1-norms of the rows in DN, of the columns in DTMP. We C save the pointers to the diagonal elements in IDA, and check for C small diagonal elements. C X DO 20 I = 1, NROW X IDA(I) = 0 X K = IA(I) X J = IA(I+1) - K X DN(I) = DASUM(J,A(K),1) X K = ILU(I) X J = ILU(I+1) - K X DTMP = DASUM(J,LU(K),1) X DNRM = MAX(DTMP,DN(I)) X DO 10 K = IA(I), IA(I+1)-1 X IF (JA(K).NE.I) GO TO 10 X IDA(I) = K X DTMP = DADD(DNRM,A(K)) X IF (DTMP.NE.DNRM) GO TO 20 X WRITE (6,'(A30,I10,E25.18)') 'Small diagonal on row:', X $ I, A(K) X PRECON = -1 X GO TO 20 X 10 CONTINUE X 20 CONTINUE X IF (PRECON.NE.1) RETURN C C Get the fill-in and tolerance from the user. C X FILL = (NZMAX - IA(NROW+1) + 1) / NROW X FILL = MIN(FILL,NROW) X FILL = FILL / 2 X WRITE (6,'(A17,I5)') 'Maximal fill-in: ', FILL X WRITE (6,'(A17,$)') 'Enter fill-in : ' X READ (5,'(I10)') I X FILL = MIN(FILL,I) X WRITE (6,'(A17,$)') 'Enter tolerance: ' X READ (5,*) TOL C C Compute the ILUT. C X WRITE (6,'(A16,I6)') 'Elements in A : ', IA(NROW+1)-1 X CALL ILUT(NROW,A,JA,IA,IDA,LU,JLU,ILU,TOL,FILL,ITMP, X $ DN,DR,XTMP) X WRITE (6,'(A16,I6)') 'Elements in LU: ', ILU(NROW+1)-1 C C Make a file with it? C X WRITE (6,'(A32,$)') 'Dump LU to file (1=Yes, 0=No) ? ' X READ (5,'(I10)') I X IF (I.EQ.1) THEN X DO 50 I = 1, NROW X WRITE (15,'(3I5,E30.18)') I, I, I, 1.0/LU(I) X DO 40 K = ILU(I), ILU(I+1)-1 X J = JLU(K) X WRITE (15,'(3I5,E30.18)') I, J, K, LU(K) X 40 CONTINUE X 50 CONTINUE X END IF C X RETURN X END C C********************************************************************** C X BLOCK DATA C C Purpose: C This sets the preconditioner name to 'ILUT'. C C Noel M. Nachtigal C October 23, 1990 C X INCLUDE 'precon.inc' C X DATA PNAME/'ILUT'/ C X END C C********************************************************************** SHAR_EOF chmod 0600 dble/csr/dcilut.f || echo 'restore of dble/csr/dcilut.f failed' Wc_c="`wc -c < 'dble/csr/dcilut.f'`" test 8640 -eq "$Wc_c" || echo 'dble/csr/dcilut.f: original size 8640, current size' "$Wc_c" fi # ============= dble/csr/dclilut.f ============== if test -f 'dble/csr/dclilut.f' -a X"$1" != X"-c"; then echo 'x - skipping dble/csr/dclilut.f (File already exists)' else echo 'x - extracting dble/csr/dclilut.f (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/csr/dclilut.f' && C********************************************************************** C C Copyright (C) 1991 Roland W. Freund and Noel M. Nachtigal C All rights reserved. C C This code is part of a copyrighted package. For details, see the C file `cpyrit.doc' in the current directory. C C ***************************************************************** C ANY USE OF THIS CODE CONSTITUES ACCEPTANCE OF THE TERMS OF THE C COPYRIGHT NOTICE C ***************************************************************** C C********************************************************************** C C These are the preconditioner routines for the ILUT preconditioner C applied to sparse matrices on the left. C C There are four routines: C M1I (X,Y) - computes X = M_1^{-1} * X, Y a work vector; C M1T (X,Y) - computes X = M_1^{-T} * X, Y a work vector; C M2I (X,Y) - computes X = M_2^{-1} * X, Y a work vector; C M2T (X,Y) - computes X = M_2^{-T} * X, Y a work vector; C PSETUP - sets up the ILUT preconditioner. C C For the left ILUT preconditioner, C M = M_1 * M_2 = L * U. C where C M_1 = L * U, M_2 = I. C C Noel M. Nachtigal C November 23, 1990 C C********************************************************************** C X SUBROUTINE M1I (X,Y) C C Purpose: C Computes X = M_1^{-1} * X. In the case of left ILUT, M_1 is L * U C with L a lower triangular matrix with 1's on the diagonal, and U C an upper triangular matrix, both stored in row major order. Hence C the elimination is formulated as dot products. C C Parameters: C X = the vector to apply the preconditioner to (input/output). C Y = work vector (output). C C Noel M. Nachtigal C November 23, 1990 C X DOUBLE PRECISION X(*), Y(*) C X INCLUDE 'dimblk.inc' X INCLUDE 'csr.inc' C C Local variables. C X INTEGER I, J, K X DOUBLE PRECISION DTMP C C Loop over the rows of L. C X DO 20 I = 1, NROW X DTMP = 0.0 C C Loop over the columns, up to the diagonal. C X DO 10 K = ILU(I), IDA(I)-1 X J = JLU(K) X DTMP = DTMP + LU(K) * X(J) X 10 CONTINUE C C Compute X(I). L(I,I) = 1.0. C X X(I) = X(I) - DTMP C X 20 CONTINUE C C Loop over the rows of U. C X DO 40 I = NROW, 1, -1 X DTMP = 0.0 X DO 30 K = IDA(I)+1, ILU(I+1)-1 X J = JLU(K) X DTMP = DTMP + LU(K) * X(J) X 30 CONTINUE C C Compute X(I). LU(IDA(I)) = 1.0 / U(I,I). C X X(I) = ( X(I) - DTMP ) * LU(IDA(I)) C X 40 CONTINUE C X RETURN X END C C********************************************************************** C X SUBROUTINE M1T (X,Y) C C Purpose: C Computes X = M_1^{-T} * X. In the case of left ILUT, M_1 is L * U C with L a lower triangular matrix with 1's on the diagonal, and U C an upper triangular matrix, both stored in row major order. Hence C the elimination is formulated as sums of columns subtracted from C the corresponding parts of X. C C Parameters: C X = the vector to apply the preconditioner to (input/output). C Y = work vector (output). C C Noel M. Nachtigal C November 23, 1990 C X DOUBLE PRECISION X(*), Y(*) C X INCLUDE 'dimblk.inc' X INCLUDE 'csr.inc' C C Local variables. C X INTEGER I, J, K X DOUBLE PRECISION DTMP C C Loop over the column of U^T. C X DO 20 I = 1, NROW C C Compute X(I). LU(IDA(I)) = 1.0 / U(I,I). C X X(I) = X(I) * LU(IDA(I)) C C Subtract the next column. C X DTMP = X(I) X DO 10 K = IDA(I)+1, ILU(I+1)-1 X J = JLU(K) X X(J) = X(J) - DTMP * LU(K) X 10 CONTINUE X 20 CONTINUE C C Loop over the columns of L^T. C X DO 40 I = NROW, 1, -1 C C We already have X(I), since L(I,I) = 1. Subtract the next column. C X DTMP = X(I) X DO 30 K = ILU(I), IDA(I)-1 X J = JLU(K) X X(J) = X(J) - DTMP * LU(K) X 30 CONTINUE X 40 CONTINUE C X RETURN X END C C********************************************************************** C X SUBROUTINE M2I (X,Y) C X DOUBLE PRECISION X(*), Y(*) C X RETURN X END C C********************************************************************** C X SUBROUTINE M2T (X,Y) C X DOUBLE PRECISION X(*), Y(*) C X RETURN X END C C********************************************************************** C X SUBROUTINE PSETUP C C Purpose: C This subroutine sets up the preconditioner. It assumes that the C global arrays A, IA, JA give the matrix in CSR format, and LU, C ILU, and JLU give the matrix in CSC format (transposed). We also C check for small diagonals, where small is relative to the 1-norm C of the row and the column. If a small diagonal element is found, C PRECON is set to -1. C C External routines used: C double precision dadd(dx,dy) C Computes dx + dy. Used to get around optimizers. C double precision dasum(n,dx,incx) C Computes the 1-norm of dx. C C Noel M. Nachtigal C October 31, 1990 C X INTRINSIC MAX X EXTERNAL DADD, DASUM X DOUBLE PRECISION DADD, DASUM C X INCLUDE 'dimblk.inc' X INCLUDE 'csr.inc' C C Local variables. C X INTEGER FILL, I, J, K X DOUBLE PRECISION DNRM, DTMP, TOL C C Compute the 1-norms of the rows in DN, of the columns in DTMP. We C save the pointers to the diagonal elements in IDA, and check for C small diagonal elements. C X DO 20 I = 1, NROW X IDA(I) = 0 X K = IA(I) X J = IA(I+1) - K X DN(I) = DASUM(J,A(K),1) X K = ILU(I) X J = ILU(I+1) - K X DTMP = DASUM(J,LU(K),1) X DNRM = MAX(DTMP,DN(I)) X DO 10 K = IA(I), IA(I+1)-1 X IF (JA(K).NE.I) GO TO 10 X IDA(I) = K X DTMP = DADD(DNRM,A(K)) X IF (DTMP.NE.DNRM) GO TO 20 X WRITE (6,'(A30,I10,E25.18)') 'Small diagonal on row:', X $ I, A(K) X PRECON = -1 X GO TO 20 X 10 CONTINUE X 20 CONTINUE X IF (PRECON.NE.1) RETURN C C Get the fill-in and tolerance from the user. C X FILL = (NZMAX - IA(NROW+1) + 1) / NROW X FILL = MIN(FILL,NROW) X FILL = FILL / 2 X WRITE (6,'(A17,I5)') 'Maximal fill-in: ', FILL X WRITE (6,'(A17,$)') 'Enter fill-in : ' X READ (5,'(I10)') I X FILL = MIN(FILL,I) X WRITE (6,'(A17,$)') 'Enter tolerance: ' X READ (5,*) TOL C C Compute the ILUT. C X WRITE (6,'(A16,I6)') 'Elements in A : ', IA(NROW+1)-1 X CALL ILUT(NROW,A,JA,IA,IDA,LU,JLU,ILU,TOL,FILL,ITMP, X $ DN,DR,XTMP) X WRITE (6,'(A16,I6)') 'Elements in LU: ', ILU(NROW+1)-1 C C Make a file with it? C X WRITE (6,'(A32,$)') 'Dump LU to file (1=Yes, 0=No) ? ' X READ (5,'(I10)') I X IF (I.EQ.1) THEN X DO 50 I = 1, NROW X WRITE (15,'(3I5,E30.18)') I, I, I, 1.0/LU(I) X DO 40 K = ILU(I), ILU(I+1)-1 X J = JLU(K) X WRITE (15,'(3I5,E30.18)') I, J, K, LU(K) X 40 CONTINUE X 50 CONTINUE X END IF C X RETURN X END C C********************************************************************** C X BLOCK DATA C C Purpose: C This sets the preconditioner name to 'ILUT'. C C Noel M. Nachtigal C November 23, 1990 C X INCLUDE 'precon.inc' C X DATA PNAME/'SPARSE ILUT (LEFT)'/ C X END C C********************************************************************** SHAR_EOF chmod 0600 dble/csr/dclilut.f || echo 'restore of dble/csr/dclilut.f failed' Wc_c="`wc -c < 'dble/csr/dclilut.f'`" test 7610 -eq "$Wc_c" || echo 'dble/csr/dclilut.f: original size 7610, current size' "$Wc_c" fi # ============= dble/csr/dclssor.f ============== if test -f 'dble/csr/dclssor.f' -a X"$1" != X"-c"; then echo 'x - skipping dble/csr/dclssor.f (File already exists)' else echo 'x - extracting dble/csr/dclssor.f (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/csr/dclssor.f' && C********************************************************************** C C Copyright (C) 1991 Roland W. Freund and Noel M. Nachtigal C All rights reserved. C C This code is part of a copyrighted package. For details, see the C file `cpyrit.doc' in the current directory. C C ***************************************************************** C ANY USE OF THIS CODE CONSTITUES ACCEPTANCE OF THE TERMS OF THE C COPYRIGHT NOTICE C ***************************************************************** C C********************************************************************** C C These are the preconditioner routines for the SSOR preconditioner C applied on the right, sparse matrices. C C There are five routines: C M1I (X,Y) - computes X = M_1^{-1} * X, Y a work vector; C M1T (X,Y) - computes X = M_1^{-T} * X, Y a work vector; C M2I (X,Y) - computes X = M_2^{-1} * X, Y a work vector; C M2T (X,Y) - computes X = M_2^{-T} * X, Y a work vector; C PSETUP - sets up the preconditioner (empty for SSOR). C C For the SSOR preconditioner, C M = M_1 * M_2 = ( D + w L ) D^{-1} ( D + w U ), C where C A = D + L + U. C C For left preconditioning, M_2 = I. C C Note: these routines assume that the indices in the arrays JA are C sorted in increasing order. It is the resposibility of the caller C to ensure this is true. C C Noel M. Nachtigal C October 23, 1990 C C********************************************************************** C X SUBROUTINE M1I (X,Y) C X DOUBLE PRECISION X(*), Y(*) C X INCLUDE 'dimblk.inc' X INCLUDE 'csr.inc' C C SSOR parameter OMEGA. C X DOUBLE PRECISION OMEGA X COMMON /OMG/OMEGA C C Local variables. C X INTEGER I, J, K X DOUBLE PRECISION DTMP C C If the SSOR parameter is not initialized, initialize it. C X IF (OMEGA.EQ.-1.0) THEN X WRITE (6,'(A30,$)') 'Enter SSOR parameter OMEGA : ' X READ (5,*) OMEGA X ENDIF C C Multiply by ( D + w L )^{-1}. C X DO 20 I = 1, NROW X DTMP = 0.0 X DO 10 K = IA(I), IDA(I)-1 X J = JA(K) X DTMP = DTMP + A(K) * X(J) X 10 CONTINUE X X(I) = ( X(I) - OMEGA * DTMP ) * AINV(I) X 20 CONTINUE C C Multiply by ( D + w U )^{-1} * D. C X DO 40 I = NROW, 1, -1 X DTMP = 0.0 X DO 30 K = IDA(I)+1, IA(I+1)-1 X J = JA(K) X DTMP = DTMP + A(K) * X(J) X 30 CONTINUE X X(I) = X(I) - OMEGA * DTMP * AINV(I) X 40 CONTINUE C X RETURN X END C C********************************************************************** C X SUBROUTINE M1T (X,Y) C X DOUBLE PRECISION X(*), Y(*) C X INCLUDE 'dimblk.inc' X INCLUDE 'csr.inc' C C SSOR parameter OMEGA. C X DOUBLE PRECISION OMEGA X COMMON /OMG/OMEGA C C Local variables. C X INTEGER I, J, K X DOUBLE PRECISION DTMP C C If the SSOR parameter is not initialized, initialize it. C X IF (OMEGA.EQ.-1.0) THEN X WRITE (6,'(A30,$)') 'Enter SSOR parameter OMEGA : ' X READ (5,*) OMEGA X ENDIF C C Multiply by D * ( D + w U )^{-T}. C X DO 20 I = 1, NROW X DTMP = -X(I) * OMEGA * AINV(I) X DO 10 K = IDA(I)+1, IA(I+1)-1 X J = JA(K) X X(J) = X(J) + DTMP * A(K) X 10 CONTINUE X 20 CONTINUE C C Multiply by ( D + w L )^{-T}. C X DO 40 I = NROW, 1, -1 X X(I) = X(I) * AINV(I) X DTMP = -OMEGA * X(I) X DO 30 K = IA(I), IDA(I)-1 X J = JA(K) X X(J) = X(J) + DTMP * A(K) X 30 CONTINUE X 40 CONTINUE C X RETURN X END C C********************************************************************** C X SUBROUTINE M2I (X,Y) C X DOUBLE PRECISION X(*), Y(*) C X RETURN X END C C********************************************************************** C X SUBROUTINE M2T (X,Y) C X DOUBLE PRECISION X(*), Y(*) C X RETURN X END C C********************************************************************** C X SUBROUTINE PSETUP C C Purpose: C This subroutine sets up the preconditioner. It assumes that the C global arrays A, IA, JA give the matrix in CSR format, and LU, C ILU, and JLU give the matrix in CSC format (transposed). We store C the diagonal elements inverted in AINV. We also check for small C diagonals, where small is relative to the 1-norm of the row and C the column. If a small diagonal element is found, PRECON is set C to -1. C C External routines used: C double precision dadd(dx,dy) C Computes dx + dy. Used to get around optimizers. C double precision dasum(n,dx,incx) C Computes the 1-norm of dx. C subroutine dzero(n,dx,incx) C Sets dx to zero. C C Noel M. Nachtigal C October 31, 1990 C X INTRINSIC MAX X EXTERNAL DADD, DASUM X DOUBLE PRECISION DADD, DASUM C X INCLUDE 'dimblk.inc' X INCLUDE 'csr.inc' C X INTEGER I, J, K X DOUBLE PRECISION DA, DCOL, DROW, DTMP C C Compute the 1-norms of the rows in DROW, of the columns in DCOL. C We save the pointers to the diagonal elements in IDA, and check C for small diagonal elements. C X DO 20 I = 1, NROW X IDA(I) = 0 X AINV(I) = 0.0 X K = IA(I) X J = IA(I+1) - K X DROW = DASUM(J,A(K),1) X K = ILU(I) X J = ILU(I+1) - K X DCOL = DASUM(J,LU(K),1) X DROW = MAX(DCOL,DROW) X DO 10 K = IA(I), IA(I+1)-1 X IF (JA(K).NE.I) GO TO 10 X IDA(I) = K X DA = A(K) X IF (DA.NE.0.0) AINV(I) = 1.0 / DA X DTMP = DADD(DROW,A(K)) X IF (DTMP.NE.DROW) GO TO 20 X WRITE (6,'(A30,I10,E25.18)') 'Small diagonal on row:', X $ I, A(K) X PRECON = -1 X GO TO 20 X 10 CONTINUE X 20 CONTINUE X IF (PRECON.NE.1) RETURN C X RETURN X END C C********************************************************************** C X BLOCK DATA C C Purpose: C This sets the SSOR parameter OMEGA to -1, the preconditioner name C to 'SPARSE SSOR (RIGHT)'. C C Noel M. Nachtigal C October 23, 1990 C X INCLUDE 'precon.inc' C X DOUBLE PRECISION OMEGA X COMMON /OMG/OMEGA C X DATA OMEGA/-1.0/ X DATA PNAME/'SPARSE SSOR (LEFT)'/ C X END C C********************************************************************** SHAR_EOF chmod 0600 dble/csr/dclssor.f || echo 'restore of dble/csr/dclssor.f failed' Wc_c="`wc -c < 'dble/csr/dclssor.f'`" test 6513 -eq "$Wc_c" || echo 'dble/csr/dclssor.f: original size 6513, current size' "$Wc_c" fi # ============= dble/csr/dcrilut.f ============== if test -f 'dble/csr/dcrilut.f' -a X"$1" != X"-c"; then echo 'x - skipping dble/csr/dcrilut.f (File already exists)' else echo 'x - extracting dble/csr/dcrilut.f (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/csr/dcrilut.f' && C********************************************************************** C C Copyright (C) 1991 Roland W. Freund and Noel M. Nachtigal C All rights reserved. C C This code is part of a copyrighted package. For details, see the C file `cpyrit.doc' in the current directory. C C ***************************************************************** C ANY USE OF THIS CODE CONSTITUES ACCEPTANCE OF THE TERMS OF THE C COPYRIGHT NOTICE C ***************************************************************** C C********************************************************************** C C These are the preconditioner routines for the ILUT preconditioner C applied to sparse matrices on the right. C C There are four routines: C M1I (X,Y) - computes X = M_1^{-1} * X, Y a work vector; C M1T (X,Y) - computes X = M_1^{-T} * X, Y a work vector; C M2I (X,Y) - computes X = M_2^{-1} * X, Y a work vector; C M2T (X,Y) - computes X = M_2^{-T} * X, Y a work vector; C PSETUP - sets up the ILUT preconditioner. C C For the right ILUT preconditioner, C M = M_1 * M_2 = L * U. C where C M_1 = I, M_2 = L * U. C C Noel M. Nachtigal C November 23, 1990 C C********************************************************************** C X SUBROUTINE M1I (X,Y) C X DOUBLE PRECISION X(*), Y(*) C X RETURN X END C********************************************************************** C X SUBROUTINE M1T (X,Y) C X DOUBLE PRECISION X(*), Y(*) C X RETURN X END C********************************************************************** C X SUBROUTINE M2I (X,Y) C C Purpose: C Computes X = M_2^{-1} * X. In the case of right ILUT M_2 is L * U C with L a lower triangular matrix with 1's on the diagonal, and U C an upper triangular matrix, both stored in row major order. Hence C the elimination is formulated as dot products. C C Parameters: C X = the vector to apply the preconditioner to (input/output). C Y = work vector (output). C C Noel M. Nachtigal C November 23, 1990 C X DOUBLE PRECISION X(*), Y(*) C X INCLUDE 'dimblk.inc' X INCLUDE 'csr.inc' C C Local variables. C X INTEGER I, J, K X DOUBLE PRECISION DTMP C C Loop over the rows of L. C X DO 20 I = 1, NROW X DTMP = 0.0 C C Loop over the columns, up to the diagonal. C X DO 10 K = ILU(I), IDA(I)-1 X J = JLU(K) X DTMP = DTMP + LU(K) * X(J) X 10 CONTINUE C C Compute X(I). L(I,I) = 1.0. C X X(I) = X(I) - DTMP C X 20 CONTINUE C C Loop over the rows of U. C X DO 40 I = NROW, 1, -1 X DTMP = 0.0 X DO 30 K = IDA(I)+1, ILU(I+1)-1 X J = JLU(K) X DTMP = DTMP + LU(K) * X(J) X 30 CONTINUE C C Compute X(I). LU(IDA(I)) = 1.0 / U(I,I). C X X(I) = ( X(I) - DTMP ) * LU(IDA(I)) C X 40 CONTINUE C X RETURN X END C C********************************************************************** C X SUBROUTINE M2T (X,Y) C C Purpose: C Computes X = M_2^{-T} * X. In the case of right ILUT M_2 is L * U C with L a lower triangular matrix with 1's on the diagonal, and U C an upper triangular matrix, both stored in row major order. Hence C the elimination is formulated as sums of columns subtracted from C the corresponding parts of X. C C Parameters: C X = the vector to apply the preconditioner to (input/output). C Y = work vector (output). C C Noel M. Nachtigal C November 23, 1990 C X DOUBLE PRECISION X(*), Y(*) C X INCLUDE 'dimblk.inc' X INCLUDE 'csr.inc' C C Local variables. C X INTEGER I, J, K X DOUBLE PRECISION DTMP C C Loop over the column of U^T. C X DO 20 I = 1, NROW C C Compute X(I). LU(IDA(I)) = 1.0 / U(I,I). C X X(I) = X(I) * LU(IDA(I)) C C Subtract the next column. C X DTMP = X(I) X DO 10 K = IDA(I)+1, ILU(I+1)-1 X J = JLU(K) X X(J) = X(J) - DTMP * LU(K) X 10 CONTINUE X 20 CONTINUE C C Loop over the columns of L^T. C X DO 40 I = NROW, 1, -1 C C We already have X(I), since L(I,I) = 1. Subtract the next column. C X DTMP = X(I) X DO 30 K = ILU(I), IDA(I)-1 X J = JLU(K) X X(J) = X(J) - DTMP * LU(K) X 30 CONTINUE X 40 CONTINUE C X RETURN X END C C**********************************************************************C C X SUBROUTINE PSETUP C C Purpose: C This subroutine sets up the preconditioner. It assumes that the C global arrays A, IA, JA give the matrix in CSR format, and LU, C ILU, and JLU give the matrix in CSC format (transposed). We also C check for small diagonals, where small is relative to the 1-norm C of the row and the column. If a small diagonal element is found, C PRECON is set to -1. C C External routines used: C double precision dadd(dx,dy) C Computes dx + dy. Used to get around optimizers. C double precision dasum(n,dx,incx) C Computes the 1-norm of dx. C C Noel M. Nachtigal C October 31, 1990 C X INTRINSIC MAX X EXTERNAL DADD, DASUM X DOUBLE PRECISION DADD, DASUM C X INCLUDE 'dimblk.inc' X INCLUDE 'csr.inc' C C Local variables. C X INTEGER FILL, I, J, K X DOUBLE PRECISION DNRM, DTMP, TOL C C Compute the 1-norms of the rows in DN, of the columns in DTMP. We C save the pointers to the diagonal elements in IDA, and check for C small diagonal elements. C X DO 20 I = 1, NROW X IDA(I) = 0 X K = IA(I) X J = IA(I+1) - K X DN(I) = DASUM(J,A(K),1) X K = ILU(I) X J = ILU(I+1) - K X DTMP = DASUM(J,LU(K),1) X DNRM = MAX(DTMP,DN(I)) X DO 10 K = IA(I), IA(I+1)-1 X IF (JA(K).NE.I) GO TO 10 X IDA(I) = K X DTMP = DADD(DNRM,A(K)) X IF (DTMP.NE.DNRM) GO TO 20 X WRITE (6,'(A30,I10,E25.18)') 'Small diagonal on row:', X $ I, A(K) X PRECON = -1 X GO TO 20 X 10 CONTINUE X 20 CONTINUE X IF (PRECON.NE.1) RETURN C C Get the fill-in and tolerance from the user. C X FILL = (NZMAX - IA(NROW+1) + 1) / NROW X FILL = MIN(FILL,NROW) X FILL = FILL / 2 X WRITE (6,'(A17,I5)') 'Maximal fill-in: ', FILL X WRITE (6,'(A17,$)') 'Enter fill-in : ' X READ (5,'(I10)') I X FILL = MIN(FILL,I) X WRITE (6,'(A17,$)') 'Enter tolerance: ' X READ (5,*) TOL C C Compute the ILUT. C X WRITE (6,'(A16,I6)') 'Elements in A : ', IA(NROW+1)-1 X CALL ILUT(NROW,A,JA,IA,IDA,LU,JLU,ILU,TOL,FILL,ITMP, X $ DN,DR,XTMP) X WRITE (6,'(A16,I6)') 'Elements in LU: ', ILU(NROW+1)-1 C C Make a file with it? C X WRITE (6,'(A32,$)') 'Dump LU to file (1=Yes, 0=No) ? ' X READ (5,'(I10)') I X IF (I.EQ.1) THEN X DO 50 I = 1, NROW X WRITE (15,'(3I5,E30.18)') I, I, I, 1.0/LU(I) X DO 40 K = ILU(I), ILU(I+1)-1 X J = JLU(K) X WRITE (15,'(3I5,E30.18)') I, J, K, LU(K) X 40 CONTINUE X 50 CONTINUE X END IF C X RETURN X END C C********************************************************************** C X BLOCK DATA C C Purpose: C This sets the preconditioner name to 'ILUT'. C C Noel M. Nachtigal C Movember 23, 1990 C X INCLUDE 'precon.inc' C X DATA PNAME/'SPARSE ILUT (RIGHT)'/ C X END C C********************************************************************** SHAR_EOF chmod 0600 dble/csr/dcrilut.f || echo 'restore of dble/csr/dcrilut.f failed' Wc_c="`wc -c < 'dble/csr/dcrilut.f'`" test 7610 -eq "$Wc_c" || echo 'dble/csr/dcrilut.f: original size 7610, current size' "$Wc_c" fi # ============= dble/csr/dcrssor.f ============== if test -f 'dble/csr/dcrssor.f' -a X"$1" != X"-c"; then echo 'x - skipping dble/csr/dcrssor.f (File already exists)' else echo 'x - extracting dble/csr/dcrssor.f (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/csr/dcrssor.f' && C********************************************************************** C C Copyright (C) 1991 Roland W. Freund and Noel M. Nachtigal C All rights reserved. C C This code is part of a copyrighted package. For details, see the C file `cpyrit.doc' in the current directory. C C ***************************************************************** C ANY USE OF THIS CODE CONSTITUES ACCEPTANCE OF THE TERMS OF THE C COPYRIGHT NOTICE C ***************************************************************** C C********************************************************************** C C These are the preconditioner routines for the SSOR preconditioner C applied on the right, sparse matrices. C C There are five routines: C M1I (X,Y) - computes X = M_1^{-1} * X, Y a work vector; C M1T (X,Y) - computes X = M_1^{-T} * X, Y a work vector; C M2I (X,Y) - computes X = M_2^{-1} * X, Y a work vector; C M2T (X,Y) - computes X = M_2^{-T} * X, Y a work vector; C PSETUP - sets up the preconditioner (empty for SSOR). C C For the SSOR preconditioner, C M = M_1 * M_2 = ( D + w L ) D^{-1} ( D + w U ), C where C A = D + L + U. C C For right preconditioning, M_1 = I. C C Note: these routines assume that the indices in the arrays JA are C sorted in increasing order. It is the resposibility of the caller C to ensure this is true. C C Noel M. Nachtigal C October 23, 1990 C C********************************************************************** C X SUBROUTINE M1I (X,Y) C X DOUBLE PRECISION X(*), Y(*) C X RETURN X END C C********************************************************************** C X SUBROUTINE M1T (X,Y) C X DOUBLE PRECISION X(*), Y(*) C X RETURN X END C C********************************************************************** C X SUBROUTINE M2I (X,Y) C X DOUBLE PRECISION X(*), Y(*) C X INCLUDE 'dimblk.inc' X INCLUDE 'csr.inc' C C SSOR parameter OMEGA. C X DOUBLE PRECISION OMEGA X COMMON /OMG/OMEGA C C Local variables. C X INTEGER I, J, K X DOUBLE PRECISION DTMP C C If the SSOR parameter is not initialized, initialize it. C X IF (OMEGA.EQ.-1.0) THEN X WRITE (6,'(A30,$)') 'Enter SSOR parameter OMEGA : ' X READ (5,*) OMEGA X ENDIF C C Multiply by ( D + w L )^{-1}. C X DO 20 I = 1, NROW X DTMP = 0.0 X DO 10 K = IA(I), IDA(I)-1 X J = JA(K) X DTMP = DTMP + A(K) * X(J) X 10 CONTINUE X X(I) = ( X(I) - OMEGA * DTMP ) * AINV(I) X 20 CONTINUE C C Multiply by ( D + w U )^{-1} * D. C X DO 40 I = NROW, 1, -1 X DTMP = 0.0 X DO 30 K = IDA(I)+1, IA(I+1)-1 X J = JA(K) X DTMP = DTMP + A(K) * X(J) X 30 CONTINUE X X(I) = X(I) - OMEGA * DTMP * AINV(I) X 40 CONTINUE C X RETURN X END C C********************************************************************** C X SUBROUTINE M2T (X,Y) C X DOUBLE PRECISION X(*), Y(*) C X INCLUDE 'dimblk.inc' X INCLUDE 'csr.inc' C C SSOR parameter OMEGA. C X DOUBLE PRECISION OMEGA X COMMON /OMG/OMEGA C C Local variables. C X INTEGER I, J, K X DOUBLE PRECISION DTMP C C If the SSOR parameter is not initialized, initialize it. C X IF (OMEGA.EQ.-1.0) THEN X WRITE (6,'(A30,$)') 'Enter SSOR parameter OMEGA : ' X READ (5,*) OMEGA X ENDIF C C Multiply by D * ( D + w U )^{-T}. C X DO 20 I = 1, NROW X DTMP = -X(I) * OMEGA * AINV(I) X DO 10 K = IDA(I)+1, IA(I+1)-1 X J = JA(K) X X(J) = X(J) + DTMP * A(K) X 10 CONTINUE X 20 CONTINUE C C Multiply by ( D + w L )^{-T}. C X DO 40 I = NROW, 1, -1 X X(I) = X(I) * AINV(I) X DTMP = -OMEGA * X(I) X DO 30 K = IA(I), IDA(I)-1 X J = JA(K) X X(J) = X(J) + DTMP * A(K) X 30 CONTINUE X 40 CONTINUE C X RETURN X END C C********************************************************************** C X SUBROUTINE PSETUP C C Purpose: C This subroutine sets up the preconditioner. It assumes that the C global arrays A, IA, JA give the matrix in CSR format, and LU, C ILU, and JLU give the matrix in CSC format (transposed). We store C the diagonal elements inverted in AINV. We also check for small C diagonals, where small is relative to the 1-norm of the row and C the column. If a small diagonal element is found, PRECON is set C to -1. C C External routines used: C double precision dadd(dx,dy) C Computes dx + dy. Used to get around optimizers. C double precision dasum(n,dx,incx) C Computes the 1-norm of dx. C subroutine dzero(n,dx,incx) C Sets dx to zero. C C Noel M. Nachtigal C October 31, 1990 C X INTRINSIC MAX X EXTERNAL DADD, DASUM X DOUBLE PRECISION DADD, DASUM C X INCLUDE 'dimblk.inc' X INCLUDE 'csr.inc' C X INTEGER I, J, K X DOUBLE PRECISION DA, DCOL, DROW, DTMP C C Compute the 1-norms of the rows in DROW, of the columns in DCOL. C We save the pointers to the diagonal elements in IDA, and check C for small diagonal elements. C X DO 20 I = 1, NROW X IDA(I) = 0 X AINV(I) = 0.0 X K = IA(I) X J = IA(I+1) - K X DROW = DASUM(J,A(K),1) X K = ILU(I) X J = ILU(I+1) - K X DCOL = DASUM(J,LU(K),1) X DROW = MAX(DCOL,DROW) X DO 10 K = IA(I), IA(I+1)-1 X IF (JA(K).NE.I) GO TO 10 X IDA(I) = K X DA = A(K) X IF (DA.NE.0.0) AINV(I) = 1.0 / DA X DTMP = DADD(DROW,A(K)) X IF (DTMP.NE.DROW) GO TO 20 X WRITE (6,'(A30,I10,E25.18)') 'Small diagonal on row:', X $ I, A(K) X PRECON = -1 X GO TO 20 X 10 CONTINUE X 20 CONTINUE X IF (PRECON.NE.1) RETURN C X RETURN X END C C********************************************************************** C X BLOCK DATA C C Purpose: C This sets the SSOR parameter OMEGA to -1, the preconditioner name C to 'SPARSE SSOR (RIGHT)'. C C Noel M. Nachtigal C October 23, 1990 C X INCLUDE 'precon.inc' C X DOUBLE PRECISION OMEGA X COMMON /OMG/OMEGA C X DATA OMEGA/-1.0/ X DATA PNAME/'SPARSE SSOR (RIGHT)'/ C X END C C********************************************************************** SHAR_EOF chmod 0600 dble/csr/dcrssor.f || echo 'restore of dble/csr/dcrssor.f failed' Wc_c="`wc -c < 'dble/csr/dcrssor.f'`" test 6521 -eq "$Wc_c" || echo 'dble/csr/dcrssor.f: original size 6521, current size' "$Wc_c" fi # ============= dble/csr/dcsr.f ============== if test -f 'dble/csr/dcsr.f' -a X"$1" != X"-c"; then echo 'x - skipping dble/csr/dcsr.f (File already exists)' else echo 'x - extracting dble/csr/dcsr.f (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/csr/dcsr.f' && C********************************************************************** C C Copyright (C) 1991 Roland W. Freund and Noel M. Nachtigal C All rights reserved. C C This code is part of a copyrighted package. For details, see the C file `cpyrit.doc' in the current directory. C C ***************************************************************** C ANY USE OF THIS CODE CONSTITUES ACCEPTANCE OF THE TERMS OF THE C COPYRIGHT NOTICE C ***************************************************************** C C********************************************************************** C C This file contains support routines for sparse matrices. Most of C the routines herein use SPARSKIT routines to handle the matrix. C SPARSKIT is Copyright 1990, Youcef Saad. The following routines C are in this file: C C SUBROUTINE AXB (X,B) C Computes B = A * X. A is preconditioned. C SUBROUTINE ATXB (X,B) C Computes B = A^T * X. A is preconditioned. C SUBROUTINE GETMAT C Reads in a sparse matrix from a Boeing-Harwell format file. C DOUBLE PRECISION FUNCTION GETNRM() C Returns an estimate for the norm of the matrix based on using C Gershgorin disks. C SUBROUTINE SORTJA (N,AROW,JROW) C Sorts the indices in JROW in increasing order. C C********************************************************************** C X SUBROUTINE AXB (X,B) C C Purpose: C This subroutine computes B = A * X, for a sparse matrix A. The C code assumes that A is preconditioned to M_1^{-1} A M_2^{-1}. C C Parameters: C X = the vector to be multiplied by A (input). C B = the result of the multiplication (output). C C External routines used: C subroutine amux(nrow,x,b,a,ja,ia) C SPARSKIT routine to compute sparse matrix-vector product. C subroutine dcopy(n,dx,incx,dy,incy) C Computes dy = dx. C subroutine m1i(x,y) C Computes x = M_1^{-1} * x. C subroutine m2i(x,y) C Computes x = M_2^{-1} * x. C C Noel M. Nachtigal C September 27, 1990 C X DOUBLE PRECISION B(*), X(*) C X INCLUDE 'dimblk.inc' X INCLUDE 'csr.inc' C C Copy X to the local vector. C X CALL DCOPY (NROW,X,1,XTMP,1) C C Multiply by preconditioner matrix M_2^{-1}. C X IF (PRECON.EQ.1) CALL M2I (XTMP,B) C C Multiply by A. C X CALL AMUX (NROW,XTMP,B,A,JA,IA) C C Multiply by the preconditioner matrix M_1^{-1}. C X IF (PRECON.EQ.1) CALL M1I (B,XTMP) C X RETURN X END C C********************************************************************** C X SUBROUTINE ATXB (X,B) C C Purpose: C This subroutine computes B = A^T * X, for sparse matrix A. The C code assumes that A is preconditioned to M_1^{-1} A M_2^{-1}. C C Parameters: C X = the vector to be multiplied by A^T (input). C B = the result of the multiplication (output). C C External routines used: C subroutine atmux(nrow,x,b,a,ja,ia) C SPARSKIT routine to compute sparse matrix-vector product with C the transposed matrix. C subroutine dcopy(n,dx,incx,dy,incy) C Computes dy = dx. C subroutine m1t(x,y) C Computes x = M_1^{-T} * x. C subroutine m2t(x,y) C Computes x = M_2^{-T} * x. C C Noel M. Nachtigal C September 27, 1990 C X DOUBLE PRECISION B(*),X(*) C X INCLUDE 'dimblk.inc' X INCLUDE 'csr.inc' C C Copy X to the local vector. C X CALL DCOPY (NROW,X,1,XTMP,1) C C Multiply by preconditioner matrix M_1^{-T}. C X IF (PRECON.EQ.1) CALL M1T (XTMP,B) C C Multiply by A. C X CALL ATMUX (NROW,XTMP,B,A,JA,IA) C C Multiply by preconditioner matrix M_2^{-T} C X IF (PRECON.EQ.1) CALL M2T (B,XTMP) C X RETURN X END C C********************************************************************** C X SUBROUTINE GETMAT C C Purpose: C This subroutine initializes the matrix by reading it from a user- C specified Boeing-Harwell format data file. Optionally, it will C also convert the matrix to a dense matrix and output the latter C to the ASCII file matrix.dat. Note that the Boeing-Harwell stuff C is stored in compressed sparse column format, while SPARSKIT uses C compressed sparse row format. C C External routines used: C subroutine readmt(nmax,nzmax,job,iounit,a,ja,ia,rhs,nrhs,guesol, C nrow,ncol,nnz,title,key,type,ierr) C SPARSKIT routine to read in a sparse Harwell-Boeing matrix. C subroutine csrcsc(n,job,ipos,a,ja,ia,ao,jao,iao) C Convert a CSR matrix to CSC format or vice-versa. C C Noel M. Nachtigal C September 27, 1990 C X INCLUDE 'dimblk.inc' X INCLUDE 'csr.inc' C C Local variables. C X CHARACTER ANS*1, GUESOL*2, KEY*8, TITLE*72, TYPE*3 X INTEGER I, IERR, IOUNIT, J, J1, J2, JOB, K, NRHS, NNZ X DOUBLE PRECISION RHS C C Get the data file from the user. C X WRITE (6,'(A29,$)') 'Enter sparse data file name: ' X READ (5,'(A72)') TITLE C C Open the file. C X OPEN (10,FILE=TITLE) C C Call the SPARSKIT routine to read in the matrix. C X JOB = 2 X NRHS = 0 X IOUNIT = 10 X CALL READMT (NDIM,NZMAX,JOB,IOUNIT,LU,JLU,ILU,RHS,NRHS,GUESOL, X $ NROW,NCOL,NNZ,TITLE,KEY,TYPE,IERR) X CLOSE (10) C C Output the matrix parameters. C X WRITE (6,'(A7,I10)') 'NDIM :',NDIM X WRITE (6,'(A7,I10)') 'NZMAX :',NZMAX X WRITE (6,'(A7,I10)') 'JOB :',JOB X WRITE (6,'(A7,I10)') 'NRHS :',NRHS X WRITE (6,'(A7,A10)') 'GUESOL:',GUESOL X WRITE (6,'(A7,I10)') 'NROW :',NROW X WRITE (6,'(A7,I10)') 'NCOL :',NCOL X WRITE (6,'(A7,I10)') 'NNZ :',NNZ X WRITE (6,'(A7,A73)') 'TITLE :',TITLE X WRITE (6,'(A7,A11)') 'KEY :',KEY X WRITE (6,'(A7,A10)') 'TYPE :',TYPE X WRITE (6,'(A7,I10)') 'IERR :',IERR C C Check for errors. C X IF (IERR.NE.0) STOP C C Convert the matrix to CSR format (transpose it). C X CALL CSRCSC (NROW,1,1,LU,JLU,ILU,A,JA,IA) C C Order the indices in ascending order. C X DO 10 I = 1, NROW X K = IA(I) X J = IA(I+1) - K X CALL SORTJA (J,A(K),JA(K)) X K = ILU(I) X J = ILU(I+1) - K X CALL SORTJA (J,LU(K),JLU(K)) X 10 CONTINUE C C Does the user want a dense matrix file? C C WRITE (6,'(A38,$)') 'Produce dense matrix data file (Y/N)? ' C READ (5,'(A1)') ANS X ANS = 'N' C C Make the dense matrix file. The matrix is output by columns. C X IF ((ANS.EQ.'Y').OR.(ANS.EQ.'y')) THEN X OPEN (12,FILE='matrix.dat') X WRITE (12,'(I20)') NROW X DO 50 I = 1, NROW X J1 = 1 X DO 30 K = ILU(I), ILU(I+1)-1 X J2 = JLU(K) X DO 20 J = J1, J2-1 X WRITE (12,'(E25.17)') 0.0 X 20 CONTINUE X WRITE (12,'(E25.17)') LU(K) X J1 = J2 + 1 X 30 CONTINUE X DO 40 J = J1, NCOL X WRITE (12,'(E25.17)') 0.0 X 40 CONTINUE X 50 CONTINUE X CLOSE (12) X END IF C X RETURN X END C C********************************************************************** C X DOUBLE PRECISION FUNCTION GETNRM () C C Purpose: C This function returns an estimate for the norm of the matrix. The C current estimate is based on Gershgorin disks. C C External routines used: C subroutine cnrms(nrow,nrm,a,ja,ia,diag) C SPARSKIT routine to compute column norms. C integer function idamax(n,x,incx) C Computes the index of the largest entry in magnitude. C subroutine rnrms(nrow,nrm,a,ja,ia,diag) C SPARSKIT routine to compute row norms. C C Noel M. Nachtigal C September 27, 1990 C X INTEGER IDAMAX X EXTERNAL IDAMAX X INTRINSIC MIN C X INCLUDE 'dimblk.inc' X INCLUDE 'csr.inc' C C Local variables. C X INTEGER IDX, NRM X DOUBLE PRECISION DIAG(NDIM-1), DTMP1, DTMP2 C X NRM = 1 X CALL CNRMS (NROW,NRM,A,JA,IA,DIAG) X IDX = IDAMAX(NROW,DIAG,1) X DTMP1 = DIAG(IDX) X CALL RNRMS (NROW,NRM,A,JA,IA,DIAG) X IDX = IDAMAX(NROW,DIAG,1) X DTMP2 = DIAG(IDX) X GETNRM = MIN(DTMP1,DTMP2) C X RETURN X END C C********************************************************************** C X SUBROUTINE SORTJA (N,AROW,JROW) C C Purpose: C This is a SPARSKIT subroutine to sort the column indices of a row C of a matrix stored in compressed sparse row (CSR) format in order C (increasing). The routine is given the array of elements of the C row in AROW, with the corresponding column indices in JROW. Both C arrays are of length N; the elements are given so that they can C be kept in correspondence with the elements in AROW. C The routine uses Heapsort to carry out the sorting; the code is C copied verbatim from Numerical Recipes (minus the bugs). C C Parameters: C N = the length of the row (input). C AROW = the row to be sorted (input/output). C JROW = the array of matching column indices (input/output). C C Noel M. Nachtigal C October 28, 1990 C X INTRINSIC ABS C X INTEGER N, JROW(*) X DOUBLE PRECISION AROW(*) C C Local variables. C X INTEGER I, J, JTMP, K, L X DOUBLE PRECISION DTMP C X IF (N.LE.1) RETURN C X L = N / 2 + 1 X K = N X 10 IF (L.GT.1) THEN X L = L - 1 X DTMP = AROW(L) X JTMP = JROW(L) X ELSE X DTMP = AROW(K) X JTMP = JROW(K) X AROW(K) = AROW(1) X JROW(K) = JROW(1) X K = K - 1 X IF (K.LE.1) THEN X AROW(1) = DTMP X JROW(1) = JTMP X RETURN X END IF X END IF X I = L X J = L + L X 20 IF (J.LE.K) THEN X IF (J.LT.K) THEN X IF (JROW(J).LT.JROW(J+1)) J = J + 1 X END IF X IF (JTMP.LT.JROW(J)) THEN X AROW(I) = AROW(J) X JROW(I) = JROW(J) X I = J X J = J + J X ELSE X J = K + 1 X END IF X GO TO 20 X END IF X AROW(I) = DTMP X JROW(I) = JTMP X GO TO 10 C X END C C********************************************************************** X SHAR_EOF chmod 0600 dble/csr/dcsr.f || echo 'restore of dble/csr/dcsr.f failed' Wc_c="`wc -c < 'dble/csr/dcsr.f'`" test 10293 -eq "$Wc_c" || echo 'dble/csr/dcsr.f: original size 10293, current size' "$Wc_c" fi # ============= dble/csr/ilut.f ============== if test -f 'dble/csr/ilut.f' -a X"$1" != X"-c"; then echo 'x - skipping dble/csr/ilut.f (File already exists)' else echo 'x - extracting dble/csr/ilut.f (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/csr/ilut.f' && C********************************************************************** C C Copyright (C) 1991 Roland W. Freund and Noel M. Nachtigal C All rights reserved. C C This code is part of a copyrighted package. For details, see the C file `cpyrit.doc' in the current directory. C C ***************************************************************** C ANY USE OF THIS CODE CONSTITUES ACCEPTANCE OF THE TERMS OF THE C COPYRIGHT NOTICE C ***************************************************************** C C********************************************************************** C C These are the setup routines for the ILUT preconditioners applied C to sparse matrices. C C There are two routines: C ILUT - carries out the ILUT decomposition; C SORT - used by ILUT. C C Noel M. Nachtigal C November 23, 1990 C C********************************************************************** C X SUBROUTINE ILUT (NROW,A,JA,IA,IDA,LU,JLU,ILU,TOL,FILL,ITMP,DN,DR, X $ DS) C C Purpose: C This subroutine computes the Incomplete LU decomposition of A C with a variant of the dual thresholding strategy. C C Parameters: C NROW = the dimension of A (input). C A = the matrix A in compressed sparse row format (input). C JA = the array of column indices (input). C IA = the array of pointers to the rows' data (input). C IDA = on entry, the array of pointers to the locations of the C diagonal entries of the matrix in the array A; on exit, it C gives the location of the diagonal elements of U in the C array LU (input/output). C LU = the triangular matrices L and U, stored in modified sparse C row (MSR) format. L has 1's on the diagonal, not stored, C while the diagonal of U is stored inverted in LU(1:NROW) C (output). C JLU = the array of column indices (output). C ILU = the array of pointers to the rows' data (output). C TOL = tolerance (input). C FILL = additional fill allowed for each row of L and U (input). C ITMP = work array of NROW integers (output). C DN = work array with the norms of the rows (input). C DR = work array used to compute each row of L and U (output). C DS = work array used for the sort routine (output). C C External routines used: C subroutine dscal(n,da,dx,incx) C Computes dx = da * dx. C subroutine sort(n,idx,dx) C Builds an index table for the elements of dx, sorted in order C of decreasing value. C C Noel M. Nachtigal C October 30, 1990 C X INTRINSIC ABS, MAX, MIN C X INTEGER FILL, IA(*), IDA(*), ILU(*), ITMP(*), JA(*), JLU(*) X INTEGER NROW X DOUBLE PRECISION A(*), LU(*), DN(*), DR(*), DS(*), TOL C C Local variables. C X INTEGER I, IPTR, J, JJ, K, KK, LENL, LENU X DOUBLE PRECISION AVGV, DTMP C C Initialize the pointer to the next free slot. C X IPTR = 1 C C We construct the matrices L and U one row at a time. C X DO 100 I = 1, NROW C C Set the pointer in ILU. C X ILU(I) = IPTR C C Copy the current row of A into the temporary vector and compute C the lengths LENL and LENU. We will build the rows of L and U by C modifying the temporary vector itself. C X CALL DSCAL (NROW,0.0D0,DR,1) X DO 10 K = IA(I), IA(I+1)-1 X DR(JA(K)) = A(K) X 10 CONTINUE X LENL = IDA(I) - IA(I) + FILL X LENU = IA(I+1) - IDA(I) + FILL - 1 X IF (LENL.LT.0) LENL = 0 X IF (LENU.LT.0) LENU = 0 X AVGV = TOL * DN(I) / FLOAT(K) C C Compute the row of L. The first element will appear in the same C column as the first nonzero element of this row of A. When we are C done computing the L part, elements I to NROW are the row of U. J C is the column index of the element of L being computed. C X DO 30 J = JA(IA(I)), I-1 C C If the (I,J) element is zero, no need to eliminate. Otherwise, C compute L(I,J). Recall that the diagonal elements of U are stored C inverted in LU(IDA(1:NROW)), so LU((IDA(J)) is 1/U(J,J). C X DTMP = DR(J) X IF (DTMP.EQ.0.0) GO TO 30 X DTMP = DTMP * LU(IDA(J)) X DR(J) = DTMP C C Add to the temporary vector the multiple of row J of U. This is C the step that would eliminate the (I,J) entry in A. Here, JJ is C the column index of the entries in row J; we want the entries to C the right of column J only. C X DO 20 KK = ILU(J), ILU(J+1)-1 X JJ = JLU(KK) X IF (JJ.GT.J) THEN X DR(JJ) = DR(JJ) - DTMP * LU(KK) X END IF X 20 CONTINUE X 30 CONTINUE C C Row I of L and U is computed. Extract the indices of the nonzero C elements of L and set up the vector for sorting, in case we have C to do it. C X K = 1 X DO 50 J = 1, I-1 X IF (DR(J).NE.0.0) THEN X DS(J) = ABS(DR(J)) * DN(J) X ITMP(K) = J X K = K + 1 X END IF X 50 CONTINUE X K = K - 1 C C There are K nonzero elements in this row of L. If this exceeds C the maximum allowed number LENL, then we extract the largest ones C sorted in the form ABS(L(I,J)) * NORM_1(U(J,:)). C X IF (K.GT.LENL) THEN X CALL SORT (K,ITMP,DS) X END IF C C Extract the (possibly LENL largest) nonzero elements of L. Here, C for the comparison, each element is scaled by the norm of the C corresponding row of U. We drop elements that have (ABS(L(I,J)) C * NORM(U(J,:))).LT.(TOL * NORM_1(A(I,:))). C X DTMP = TOL * DN(I) X DO 60 J = 1, MIN(K,LENL) X JJ = ITMP(J) X IF (DS(JJ).LT.DTMP) GO TO 70 X JLU(IPTR) = JJ X LU(IPTR) = DR(JJ) X IPTR = IPTR + 1 X 60 CONTINUE X 70 CONTINUE C C Save the index of the diagonal element. C X JLU(IPTR) = I X LU(IPTR) = 0.0 X IDA(I) = IPTR X IPTR = IPTR + 1 C C Extract the indices of the nonzero elements of U and set up the C vector for sorting, in case we have to do it. C X K = 1 X DO 80 J = I+1, NROW X IF (DR(J).NE.0.0) THEN X DS(J) = ABS(DR(J)) X ITMP(K) = J X K = K + 1 X END IF X 80 CONTINUE X K = K - 1 C C There are K nonzero elements in this row of U. If this exceeds C the maximum allowed number LENU, then we extract the largest ones C sorted order of magnitude. C X IF (K.GT.LENU) THEN X CALL SORT (K,ITMP,DS) X END IF C C Extract the (possibly LENU largest) nonzero elements of L. Also, C compute the 1-norm of this row of U and store it. Since we don't C have a good strategy, we don't drop any elements from U (from the C ones we take up to fill-in). C X DTMP = 0.0 X DO 90 J = 1, MIN(K,LENU) X JJ = ITMP(J) X JLU(IPTR) = JJ X LU(IPTR) = DR(JJ) X IPTR = IPTR + 1 X DTMP = DTMP + DS(JJ) X 90 CONTINUE X DN(I) = DTMP C C Sort the indices and shuffle the elements accordingly. C X K = ILU(I) X J = IPTR - K X CALL SORTJA (J,LU(K),JLU(K)) C C Extract the diagonal element. If it is small, replace it with the C averaged 1-norm of this row of A. Store it inverted. C X DTMP = DR(I) X IF (ABS(DTMP).LT.AVGV) THEN X IF (DTMP.LT.0.0) THEN X DTMP = -AVGV X ELSE X DTMP = AVGV X END IF X END IF X LU(IDA(I)) = 1.0 / DTMP C X 100 CONTINUE C C Set the last pointer in ILU. C X ILU(NROW+1) = IPTR C X RETURN X END C C********************************************************************** C X SUBROUTINE SORT (N,IDX,X) C C Purpose: C This routine builds an index in IDX for the sorted order of the C elements in X, sorted in decreasing order. Note that this is not C according to magnitude, it is according to value, and that the C elements of X are not moved at all. Their position is governed by C the indices in IDX: the Ith element in X is found in slot IDX(I). C This must be on entry, hence IDX must be initialized on input. It C is also true on exit. The routine uses Heapsort to carry out the C sorting; the code is copied verbatim from Numerical Recipes. C C Parameters: C N = the length of X and IDX (input). C IDX = the indices array, sorted so that the corresponding entries C of X are sorted in descrending order (input/output). C X = the array of values (input). C C External routines used: C C Noel M. Nachtigal C October 31, 1990 C X INTEGER N, IDX(*) X DOUBLE PRECISION X(*) C C Local variables. C X INTEGER I, J, JTMP, K, L X DOUBLE PRECISION DTMP C X IF (N.LE.1) RETURN C X L = N / 2 + 1 X K = N X 10 IF (L.GT.1) THEN X L = L - 1 X JTMP = IDX(L) X DTMP = X(JTMP) X ELSE X JTMP = IDX(K) X DTMP = X(JTMP) X IDX(K) = IDX(1) X K = K - 1 X IF (K.EQ.1) THEN X IDX(1) = JTMP X RETURN X END IF X END IF X I = L X J = L + L X 20 IF (J.LE.K) THEN X IF (J.LT.K) THEN X IF (X(IDX(J)).GT.X(IDX(J+1))) J = J + 1 X END IF X IF (DTMP.GT.X(IDX(J))) THEN X IDX(I) = IDX(J) X I = J X J = J + J X ELSE X J = K + 1 X END IF X GO TO 20 X END IF X IDX(I) = JTMP X GO TO 10 C X END C C********************************************************************** SHAR_EOF chmod 0600 dble/csr/ilut.f || echo 'restore of dble/csr/ilut.f failed' Wc_c="`wc -c < 'dble/csr/ilut.f'`" test 9872 -eq "$Wc_c" || echo 'dble/csr/ilut.f: original size 9872, current size' "$Wc_c" fi # ============= dble/csr/makefile ============== if test -f 'dble/csr/makefile' -a X"$1" != X"-c"; then echo 'x - skipping dble/csr/makefile (File already exists)' else echo 'x - extracting dble/csr/makefile (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/csr/makefile' && #********************************************************************** # # Copyright (C) 1991 Roland W. Freund and Noel M. Nachtigal # All rights reserved. # # This code is part of a copyrighted package. For details, see the # file `cpyrit.doc' in the current directory. # # ***************************************************************** # ANY USE OF THIS CODE CONSTITUES ACCEPTANCE OF THE TERMS OF THE # COPYRIGHT NOTICE # ***************************************************************** # #********************************************************************** # # Makefile for the sparse matrix subdirectory. # # Files in this directory: # INC = dimblk.inc precon.inc FOR = OBJ = dcilut.o dclilut.o dcrilut.o dclssor.o dcrssor.o dcsr.o ilut.o \ X sparskit.o dcsrpr.o SRC = dcilut.f dclilut.f dcrilut.f dclssor.f dcrssor.f dcsr.f ilut.f \ X sparskit.f csr.inc X # # Include here the skeleton makefile. # include ../skeleton.mak include ../local.mak X # # Additional targets in this directory. # cilut: dcilut.o X @$(CP) dcilut.o dcsrpr.o X @$(ECHO) Sparse ILUT preconditioner set up, now recompile. X clilut: dclilut.o X @$(CP) dcilut.o dcsrpr.o X @$(ECHO) Sparse left ILUT preconditioner set up, now recompile. X clssor: dclssor.o X @$(CP) dcilut.o dcsrpr.o X @$(ECHO) Sparse left SSOR preconditioner set up, now recompile. X crilut: dcrilut.o X @$(CP) dcilut.o dcsrpr.o X @$(ECHO) Sparse right ILUT preconditioner set up, now recompile. X crssor: dcrssor.o X @$(CP) dcilut.o dcsrpr.o X @$(ECHO) Sparse right SSOR preconditioner set up, now recompile. X # # This is the local help target. # lochelp: X @$(ECHO) " crssor - set up CSR SSOR right preconditioner" X @$(ECHO) " clssor - set up CSR SSOR left preconditioner" X @$(ECHO) " cilut - set up CSR ILUT preconditioner" X @$(ECHO) " clilut - set up CSR ILUT left preconditioner" X @$(ECHO) " crilut - set up CSR ILUT right preconditioner" X # # Dependencies for files in this directory. # dcilut.o: dcilut.f csr.inc dimblk.inc precon.inc X dclilut.o: dclilut.f csr.inc dimblk.inc precon.inc X dclssor.o: dclssor.f csr.inc dimblk.inc precon.inc X dcrilut.o: dcrilut.f csr.inc dimblk.inc precon.inc X dcrssor.o: dcrssor.f csr.inc dimblk.inc precon.inc X dcsr.o: dcsr.f csr.inc dimblk.inc X ilut.o: ilut.f X sparskit.o: sparskit.f X dcsrpr.o: dcilut.o X @$(CP) dcilut.o dcsrpr.o SHAR_EOF chmod 0600 dble/csr/makefile || echo 'restore of dble/csr/makefile failed' Wc_c="`wc -c < 'dble/csr/makefile'`" test 2395 -eq "$Wc_c" || echo 'dble/csr/makefile: original size 2395, current size' "$Wc_c" fi # ============= dble/csr/sparskit.f ============== if test -f 'dble/csr/sparskit.f' -a X"$1" != X"-c"; then echo 'x - skipping dble/csr/sparskit.f (File already exists)' else echo 'x - extracting dble/csr/sparskit.f (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/csr/sparskit.f' && C********************************************************************** C C These are support routines from SPARSKIT, a sparse matrix package C developed by Youcef Saad. For more information on the package, or C information on how to obtain the complete package, please contact C Youcef Saad at na.saad@na-net.ornl.gov or saad@cs.umn.edu. C The following is the copyright notice from the package. C C Copyright @1990 Youcef Saad. C ---------------------------- C Permission to copy all or part of any material contained C in SPARSKIT is only granted upon approval from Youcef Saad. C Not any portion of SPARSKIT can be used for commercial C purposes or as part of a commercial package. This notice C should accompany the package in any approved copy. C C Note to contributors: Before contributing any software C be aware that above note is the only global limitation C against copying software. Eventually this copyright note C may be replaced. C C DISCLAIMER C ---------- C SPARSKIT comes with no warranty whatsoever. C The author/contributors of SPARKSIT are not liable C for any loss/damage or inconvenience caused in the use C of the software in SPARSKIT or any modification thereof. C C********************************************************************** X SUBROUTINE AMUX (NROW,X,Y,A,JA,IA) X INTEGER JA(*),IA(*),NROW X DOUBLE PRECISION A(*),X(*),Y(*) X INTEGER I,K X DOUBLE PRECISION DTMP X DO 20 I=1,NROW X DTMP=0.0 X DO 10 K=IA(I),IA(I+1)-1 X DTMP=DTMP+A(K)*X(JA(K)) X 10 CONTINUE X Y(I)=DTMP X 20 CONTINUE X RETURN X END C********************************************************************** X SUBROUTINE ATMUX (NROW,X,Y,A,JA,IA) X INTEGER NROW,IA(*),JA(*) X DOUBLE PRECISION A(*),X(*),Y(*) X INTEGER I,J,K X DO 10 I=1,NROW X Y(I)=0.0 X 10 CONTINUE X DO 30 I=1,NROW X DO 20 K=IA(I),IA(I+1)-1 X J=JA(K) X Y(J)=Y(J)+X(I)*A(K) X 20 CONTINUE X 30 CONTINUE X RETURN X END C********************************************************************** X SUBROUTINE CNRMS (NROW,NRM,A,JA,IA,DIAG) X INTRINSIC ABS,MAX,SQRT X INTEGER IA(NROW+1),JA(*),NROW,NRM X DOUBLE PRECISION A(*),DIAG(NROW) X INTEGER I,J,K X DO 10 K=1,NROW X DIAG(K)=0.0 X 10 CONTINUE X DO 30 I=1,NROW X DO 20 K=IA(I),IA(I+1)-1 X J=JA(K) X IF (NRM.EQ.0) THEN X DIAG(J)=MAX(DIAG(J),ABS(A(K))) X ELSE IF (NRM.EQ.1) THEN X DIAG(J)=DIAG(J)+ABS(A(K)) X ELSE X DIAG(J)=DIAG(J)+A(K)**2 X END IF X 20 CONTINUE X 30 CONTINUE X IF (NRM.EQ.2) THEN X DO 40 K=1,NROW X DIAG(K)=SQRT(DIAG(K)) X 40 CONTINUE X END IF X RETURN X END C********************************************************************** X SUBROUTINE CSRCSC (N,JOB,IPOS,A,JA,IA,AO,JAO,IAO) X INTEGER IA(N+1),IAO(N+1),IPOS,JA(*),JAO(*),JOB,N X DOUBLE PRECISION A(*),AO(*) X INTEGER I,J,K,NEXT X DO 10 I=1,N+1 X IAO(I)=0 X 10 CONTINUE X DO 20 K=IA(1),IA(N+1)-1 X IAO(JA(K)+1)=IAO(JA(K)+1)+1 X 20 CONTINUE X IAO(1)=1 X DO 30 I=2,N+1 X IAO(I)=IAO(I)+IAO(I-1) X 30 CONTINUE X DO 50 I=1,N X DO 40 K=IA(I),IA(I+1)-1 X J=JA(K) X NEXT=IAO(J) X IF (JOB.EQ.1) AO(NEXT)=A(K) X JAO(NEXT)=I X IAO(J)=NEXT+1 X 40 CONTINUE X 50 CONTINUE X DO 60 I=N+1,2,-1 X IAO(I)=IAO(I-1) X 60 CONTINUE X IAO(1)=1 X RETURN X END C********************************************************************** X SUBROUTINE READMT (NDIM,NZMAX,JOB,IOUNIT,A,JA,IA,RHS,NRHS,GUESOL, X $NROW,NCOL,NNZ,TITLE,KEY,TYPE,IERR) X CHARACTER GUESOL*2,KEY*8,TITLE*72,TYPE*3 X INTEGER IA(NDIM+1),IERR,IOUNIT,JA(NZMAX),JOB,NCOL,NDIM,NNZ X INTEGER NRHS,NROW,NZMAX X DOUBLE PRECISION A(NZMAX),RHS(*) X CHARACTER INDFMT*16,PTRFMT*16,RHSFMT*20,RHSTYP*3,VALFMT*20 X INTEGER I,IEND,INDCRD,LEN,LENRHS,N,NELTVL,NEXT,NVEC X INTEGER PTRCRD,RHSCRD,TOTCRD,VALCRD X LENRHS=NRHS X READ (IOUNIT,'(A72,A8/5I14/A3,11X,4I14/2A16,2A20)') TITLE,KEY, X $TOTCRD,PTRCRD,INDCRD,VALCRD,RHSCRD,TYPE,NROW,NCOL,NNZ,NELTVL, X $PTRFMT,INDFMT,VALFMT,RHSFMT X IF (RHSCRD.GT.0) READ (IOUNIT,'(A3,11X,I4)') RHSTYP,NRHS X IF (JOB.LE.0) RETURN X IERR=0 X N=NCOL X IF (NCOL.GT.NDIM) IERR=1 X IF (NNZ.GT.NZMAX) IERR=IERR+2 X IF (IERR.NE.0) RETURN X READ (IOUNIT,PTRFMT) (IA(I),I=1,N+1) X READ (IOUNIT,INDFMT) (JA(I),I=1,NNZ) X IF (JOB.LE.1) RETURN X IF (VALCRD.LE.0) THEN X JOB=1 X RETURN X END IF X READ (IOUNIT,VALFMT) (A(I),I=1,NNZ) X IF (JOB.LE.2) RETURN X IF (RHSCRD.LE.0) THEN X JOB=2 X RETURN X END IF X GUESOL=RHSTYP(2:3) X IF (RHSTYP(1:1).EQ.'M') THEN X IERR=4 X RETURN X END IF X NVEC=1 X IF (GUESOL(1:1).EQ.'G') NVEC=NVEC+1 X IF (GUESOL(2:2).EQ.'X') NVEC=NVEC+1 X LEN=NRHS*NROW X IF (LEN*NVEC.GT.LENRHS) THEN X IERR=5 X RETURN X END IF X NEXT=1 X IEND=LEN X READ (IOUNIT,RHSFMT) (RHS(I),I=NEXT,IEND) X IF (GUESOL(1:1).EQ.'G') THEN X NEXT=NEXT+LEN X IEND=IEND+LEN X READ (IOUNIT,VALFMT) (RHS(I),I=NEXT,IEND) X END IF X IF (GUESOL(2:2).EQ.'X') THEN X NEXT=NEXT+LEN X IEND=IEND+LEN X READ (IOUNIT,VALFMT) (RHS(I),I=NEXT,IEND) X END IF X RETURN X END C********************************************************************** X SUBROUTINE RNRMS (NROW,NRM,A,JA,IA,DIAG) X INTRINSIC ABS,MAX,SQRT X INTEGER IA(NROW+1),JA(*),NROW,NRM X DOUBLE PRECISION A(*),DIAG(NROW) X INTEGER I,K X DOUBLE PRECISION T X DO 40 I=1,NROW X T=0.0 X IF (NRM.EQ.0) THEN X DO 10 K=IA(I),IA(I+1)-1 X T=MAX(T,ABS(A(K))) X 10 CONTINUE X ELSE IF (NRM.EQ.1) THEN X DO 20 K=IA(I),IA(I+1)-1 X T=T+ABS(A(K)) X 20 CONTINUE X ELSE X DO 30 K=IA(I),IA(I+1)-1 X T=T+A(K)**2 X 30 CONTINUE X T=SQRT(T) X END IF X DIAG(I)=T X 40 CONTINUE X RETURN X END C********************************************************************** SHAR_EOF chmod 0600 dble/csr/sparskit.f || echo 'restore of dble/csr/sparskit.f failed' Wc_c="`wc -c < 'dble/csr/sparskit.f'`" test 6422 -eq "$Wc_c" || echo 'dble/csr/sparskit.f: original size 6422, current size' "$Wc_c" fi # ============= dble/dat/dns.dat ============== if test ! -d 'dble/dat'; then echo 'x - creating directory dble/dat' mkdir 'dble/dat' fi if test -f 'dble/dat/dns.dat' -a X"$1" != X"-c"; then echo 'x - skipping dble/dat/dns.dat (File already exists)' else echo 'x - extracting dble/dat/dns.dat (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/dat/dns.dat' && 20 X -3.21063185059534e+00 X 4.58476266817101e+00 X -2.31907648664053e+00 X 1.55127378833223e+00 X 2.66731341484992e-01 X 2.95417088873287e-01 X 4.23174642460786e+00 X -2.71242878294710e+00 X 6.05018758859930e+00 X 1.88601518459522e+00 X 6.14644511253882e+00 X 1.61073480378037e+00 X 1.79696352620126e+00 X 5.11822682506179e-01 X 4.29020525995485e-01 X -2.32087223718820e+00 X -2.99227843757491e+00 X -2.24509525665924e+00 X -4.94310988093554e+00 X -2.19432085895756e+00 X -2.37135465194615e+00 X -6.14065012150776e+00 X 1.58464133266391e+00 X -3.38982093836203e+00 X -2.10318173991749e+00 X -3.44512343198767e+00 X -5.27623010957099e+00 X 1.53100920058640e+00 X -3.83795680869455e+00 X -2.77985522992076e+00 X -5.44476645248059e+00 X -1.53535171712521e-01 X -1.00844978035914e+00 X -2.55960201667558e+00 X -2.28506744418821e+00 X 6.41984840908630e-01 X 7.15387750524121e-01 X -7.21027983731029e-01 X 4.47308498403994e-01 X 1.14226137514002e+00 X -6.52121190738258e-01 X -2.00670699917032e+00 X -2.15288428979516e+00 X -1.77587985847428e-01 X -3.04085870271478e+00 X -2.80295487394028e+00 X -2.84153550110564e+00 X -4.56705761113584e-01 X -4.04062565420873e-01 X -2.01653051960390e+00 X -2.84577564601232e+00 X 7.65630722130884e-01 X -1.66853288653819e+00 X -6.74729889531437e-01 X -1.62532595638727e+00 X -3.13030785896791e-01 X -1.15819762349976e-01 X -1.08380172408980e+00 X -1.62824803950522e+00 X 1.24921862378339e+00 X 2.29550188551304e+00 X -3.57113116724009e+00 X 2.53738676475648e+00 X -1.29822105980063e+00 X 6.19689819443170e-01 X 1.26579219415396e+00 X -3.24780185758239e+00 X 3.60097721552358e+00 X -3.71838795617685e+00 X -7.47800020538339e-01 X -3.77036454689264e+00 X -9.37437663008236e-01 X -1.05406113013187e+00 X 6.21026605744785e-01 X 1.02537719886621e+00 X 2.20077352556695e+00 X 3.08855630330053e+00 X 1.60716776260965e+00 X 5.22391633917537e+00 X 1.15898949985149e+00 X 5.58592977362732e+00 X 3.07005729820059e+00 X 7.11061488677780e-02 X 3.49747612385661e+00 X 4.35858095895350e+00 X 7.23678751519511e+00 X 6.86440292842641e+00 X 4.43968620775063e-01 X 4.38860519527502e-01 X 4.79370837937766e+00 X 5.47996964691271e+00 X -1.75162806642171e+00 X 7.06406631442081e-01 X 4.26863120658778e+00 X 4.32685405719282e+00 X 7.39778934607983e-01 X 1.94776807011998e+00 X 3.06897480448033e+00 X 5.94703261138194e+00 X -1.12066742337558e+00 X 1.35060760322114e+00 X -2.31115268205075e-01 X -3.86428543242924e-01 X 2.00523012784956e+00 X 5.50434959516139e-01 X -5.61131705020256e-01 X -2.91981689976845e-01 X 1.15385767233628e+00 X 4.86211202732248e-02 X 5.25275740886934e-01 X 1.98653166015257e-01 X -5.45596529891331e-01 X 1.01498889283193e-01 X 1.47852124845368e+00 X 6.38657820748833e-01 X 7.37989898941267e-02 X 1.23264291149442e+00 X -1.36665405021668e-01 X 9.38663961846147e-01 X -3.15980538496068e-01 X 5.13820943338561e+00 X -4.40674049240605e+00 X 3.14165388017666e+00 X -3.86204288536024e-01 X 1.47898416052679e+00 X 2.83610535176184e+00 X -4.66294872681437e+00 X 4.93490314940218e+00 X -5.90580754416894e+00 X -4.55335423889644e-01 X -5.38197354554576e+00 X -2.56814719753399e+00 X -2.32214255662703e+00 X 7.53008183461124e-01 X 4.09628254704057e+00 X 3.32387970443462e+00 X 5.05831581173701e+00 X 4.31057869209843e+00 X 8.96393778199468e+00 X 1.21786195932487e+00 X -3.47151322160126e+00 X 4.51822527985873e-01 X -8.56249176877475e-01 X -1.99586792612907e+00 X -1.39962674473136e+00 X -2.61602099497515e+00 X 3.27237112411694e-02 X -3.62365665689404e+00 X 9.42642876466748e-01 X -1.94572419068604e+00 X 1.13513407519279e+00 X 2.32025801117930e+00 X 6.97833858305454e-01 X -2.02420221030898e+00 X -2.62882377247642e+00 X -1.79913419855075e+00 X -1.20519834126157e+00 X -1.62754608975250e+00 X -3.82238550396268e+00 X 3.28264402223258e-01 X 7.04654712756068e+00 X 2.66592671741277e+00 X -9.62701956018075e-01 X 4.45312181609833e+00 X 2.35423598033236e+00 X 5.74023918375962e+00 X 5.19262802433131e+00 X -1.26469573015997e-01 X 3.64418849426788e-01 X 4.31754323685207e+00 X 3.42400215280580e+00 X -1.80324175494966e+00 X -3.89658578749271e-01 X 3.87975857662495e+00 X 5.83010500811462e+00 X 9.26919469480662e-01 X 1.02074305361130e+00 X 2.86911003503093e+00 X 3.88523154460757e+00 X -1.54524137516263e+00 X -3.39955732353620e+00 X -1.05838149690238e+00 X 1.58712858327604e+00 X -2.55630111071916e+00 X -7.07946764872634e-01 X -2.85309790625261e+00 X -2.83992105405950e+00 X 6.28968036544354e-01 X -1.67172121183615e+00 X -4.60256406051402e+00 X -1.43111610402831e+00 X 8.55640761399502e-01 X 9.87761822872263e-02 X -2.39261564956493e+00 X -3.43230419320055e+00 X 8.65780024439605e-01 X -3.72780550620155e-01 X -1.12232904653123e+00 X -1.66867014278829e+00 X 1.10141276316007e+00 X -7.89252124376115e+00 X 5.30582246043023e+00 X -3.35826175362412e+00 X -7.44280052108372e-01 X -3.56621999404779e+00 X -6.31842401034084e+00 X 8.19655285339668e-01 X -5.48242117635077e+00 X 7.49942848493895e+00 X -1.34393626711517e+00 X 2.54620948902203e+00 X 4.36710538434424e+00 X 2.80382559147513e+00 X -2.40286199792898e+00 X -5.35223524298389e+00 X -3.73647367443173e+00 X -5.27951359548587e+00 X -5.24109571600832e+00 X -1.27410869875756e+01 X 2.36122661473668e-01 X -3.29588634198998e-01 X -3.59944940907508e+00 X 2.15782297136559e+00 X -1.48788310106370e+00 X 3.90168758482763e-01 X -7.42487010423354e-01 X -3.77048266914445e+00 X 2.62168398760014e+00 X -4.41546332158692e+00 X -1.38714848452749e+00 X -4.50812868902475e+00 X -3.63388622689478e+00 X -8.97388820724329e-01 X -9.07392726745541e-01 X -8.62450887093328e-01 X 9.21810449109611e-01 X 1.61117542605384e+00 X 1.05165739676809e+00 X 3.73707293879927e+00 X 6.15565435034379e-01 X 1.49513709419099e-01 X 3.64025807497596e+00 X -2.43346878997784e+00 X 2.21535592999912e+00 X -5.18766811201320e-01 X 7.70141100687337e-01 X 3.05108792598617e+00 X -1.66467231244895e+00 X 4.90962920678421e+00 X 1.66156732389672e+00 X 3.95070414867575e+00 X 1.79428766021854e+00 X -4.31180494222540e-01 X 1.11471701946104e+00 X 1.39020228524645e+00 X -8.96487717054747e-01 X -1.76954575385308e+00 X -1.15660670657841e+00 X -2.98409394475978e+00 X -6.89305492429777e-01 X -3.08923043491108e+00 X 1.49356963160787e+00 X 3.45945102969319e-03 X -1.78342857097951e+00 X 3.17423583839794e-01 X -1.57925612415518e+00 X 1.49089170887413e+00 X -3.23826168448057e+00 X 5.27424558408589e-01 X -3.75490670396841e-01 X 1.42834520182528e+00 X 1.22962713622272e+00 X 8.94988242781218e-01 X -2.93964278172917e+00 X -2.41610875980093e+00 X -1.31768165431612e+00 X -1.63589650330775e+00 X -5.10730889492478e-01 X -2.89163659747535e+00 X 1.00537938991559e+00 X -1.89763524068875e+00 X 7.71635302273296e-01 X -9.25606024450218e-01 X -8.28780029882138e-01 X -9.03186118877130e-01 X -1.77309205582415e+00 X 2.53516510743862e-01 X -1.52130083680957e+00 X 3.46169840180642e-01 X -1.41460842297087e+00 X 5.40963620468923e-01 X 7.21994485662590e-01 X 4.90253564280280e-01 X -5.34848482908093e-01 X -4.25013121825122e+00 X -1.05808673037484e+00 X -7.62842172775143e-01 X -1.16480347554970e+00 X -2.74909859842485e+00 X 4.63520679202941e-01 X 5.11260430663386e+00 X -2.12958449266434e+00 X 2.72631743894874e+00 X 4.57788794817611e-01 X 3.30933447269143e+00 X 4.85854735501935e+00 X 4.88203041739084e-02 X 4.04606923273014e+00 X -3.83905011442117e+00 X 2.70305428014645e+00 X -2.16243987020120e+00 X -2.82938854967284e+00 X -7.35593105706202e-01 X 1.60328216254618e+00 X 4.31806953676078e+00 X 1.76216170440056e+00 X 3.02393601701209e+00 X 3.86133761688435e+00 X 8.60566016745035e+00 X -1.95211481989683e-01 X 4.21546007791852e+00 X -4.15145285718730e+00 X 2.95149320927983e+00 X -5.26429944921850e-01 X 3.36826058393442e-01 X 2.65025833383791e+00 X -2.68555852792311e+00 X 4.12628228079274e+00 X -5.00996387077784e+00 X 2.46653261620138e-01 X -5.63931132186545e+00 X -3.02268717922863e+00 X -2.35032712252050e+00 X 2.29523434551023e-01 X 2.69181318776135e+00 X 3.36511194335202e+00 X 4.16656876946413e-01 X 3.20602802725927e+00 X 7.21143083307469e+00 X 5.67892793462097e-01 X -2.14655715372057e+00 X 9.78831285899391e-01 X -1.06597013142968e+00 X -7.77845091287322e-02 X 9.13595118651550e-02 X -1.15896909601543e+00 X 1.25228688481414e+00 X -1.22276688556323e+00 X 1.80417862204236e+00 X -7.09879325688700e-02 X 2.33595943747959e+00 X 8.00813373218693e-01 X 8.14758901276125e-01 X -2.74155920520558e-02 X -1.25651490137518e+00 X -1.61798785687504e+00 X -9.61278587272577e-01 X -2.72920223364573e+00 X -2.08844063399759e+00 X -6.96375567498890e-01 X 5.28321541692544e-01 X -6.94823679216082e-01 X 3.81754660705624e-01 X -3.41072524646973e-01 X -1.40391422320504e+00 X -7.62239823841622e-01 X -1.55116307328877e+00 X 5.44107416530879e-01 X -4.43956858361239e-01 X 1.00402001791804e-01 X -2.38753348647772e+00 X -2.66203055843314e-01 X -1.14476711366225e-01 X -4.09979851645422e-01 X 6.00891327541649e-01 X 1.44055182267412e+00 X -4.25338930721586e-02 X 4.91049824596971e-01 X -2.24585283541431e+00 X 5.54692679934206e-01 X -4.87373816322344e+00 X 5.88325016194741e+00 X -3.81322370399677e+00 X 1.19507051730593e+00 X -1.50558403883238e+00 X -2.50588501843599e+00 X 4.46324502183558e+00 X -5.23544286192438e+00 X 7.94504391874326e+00 X 7.62500022106781e-02 X 7.67940279844550e+00 X 4.28670237908891e+00 X 2.92976252449590e+00 X -1.57444457876137e-02 X -2.82254084398163e+00 X -4.13068552530824e+00 X -4.22191287450190e+00 X -4.43059741822016e+00 X -1.02484975351684e+01 X -2.96544361764823e+00 SHAR_EOF chmod 0600 dble/dat/dns.dat || echo 'restore of dble/dat/dns.dat failed' Wc_c="`wc -c < 'dble/dat/dns.dat'`" test 9603 -eq "$Wc_c" || echo 'dble/dat/dns.dat: original size 9603, current size' "$Wc_c" fi # ============= dble/dat/dnsv.dat ============== if test -f 'dble/dat/dnsv.dat' -a X"$1" != X"-c"; then echo 'x - skipping dble/dat/dnsv.dat (File already exists)' else echo 'x - extracting dble/dat/dnsv.dat (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/dat/dnsv.dat' && X 2.18959186328090e-01 X 4.70446162144861e-02 X 6.78864716868319e-01 X 6.79296405836612e-01 X 9.34692895940828e-01 X 3.83502077489859e-01 X 5.19416372067955e-01 X 8.30965346112365e-01 X 3.45721105274614e-02 X 5.34616350445252e-02 X 5.29700193335163e-01 X 6.71149384077242e-01 X 7.69818621114743e-03 X 3.83415650754895e-01 X 6.68422375185612e-02 X 4.17485974457807e-01 X 6.86772712360496e-01 X 5.88976642856829e-01 X 9.30436494727822e-01 X 8.46166890508573e-01 SHAR_EOF chmod 0600 dble/dat/dnsv.dat || echo 'restore of dble/dat/dnsv.dat failed' Wc_c="`wc -c < 'dble/dat/dnsv.dat'`" test 480 -eq "$Wc_c" || echo 'dble/dat/dnsv.dat: original size 480, current size' "$Wc_c" fi # ============= dble/dat/dnsw.dat ============== if test -f 'dble/dat/dnsw.dat' -a X"$1" != X"-c"; then echo 'x - skipping dble/dat/dnsw.dat (File already exists)' else echo 'x - extracting dble/dat/dnsw.dat (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/dat/dnsw.dat' && X 6.66081818170010e-01 X -8.77022482290565e-01 X 1.55445785524519e-01 X -1.79342891118430e-01 X 3.97615294681875e-01 X 2.34854558127038e-01 X -3.75659284074666e-01 X 1.01445596993806e+00 X 8.73095453699247e-02 X -4.13853338933716e-01 X 7.45905504387721e-01 X -4.10639244341533e-01 X 2.31522736097942e-01 X -1.21579699910885e-01 X 1.17881556813289e-01 X -1.00772517223160e+00 X -1.09092312075030e+00 X 3.57185565552412e-01 X -7.32415233116831e-01 X 1.63055190705833e+00 SHAR_EOF chmod 0600 dble/dat/dnsw.dat || echo 'restore of dble/dat/dnsw.dat failed' Wc_c="`wc -c < 'dble/dat/dnsw.dat'`" test 480 -eq "$Wc_c" || echo 'dble/dat/dnsw.dat: original size 480, current size' "$Wc_c" fi # ============= dble/dat/csr.dat ============== if test -f 'dble/dat/csr.dat' -a X"$1" != X"-c"; then echo 'x - skipping dble/dat/csr.dat (File already exists)' else echo 'x - extracting dble/dat/csr.dat (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/dat/csr.dat' && X 7-POINT TEST MATRIX FROM SPARSKIT rua X 408 12 41 355 0 7-P 225 225 1065 0 (20I4) (26I3) (3D23.17) (3D23.17) X 1 4 8 12 16 20 24 28 32 36 40 44 48 52 56 59 63 68 73 78 X 83 88 93 98 103 108 113 118 123 128 132 136 141 146 151 156 161 166 171 176 X 181 186 191 196 201 205 209 214 219 224 229 234 239 244 249 254 259 264 269 274 X 278 282 287 292 297 302 307 312 317 322 327 332 337 342 347 351 355 360 365 370 X 375 380 385 390 395 400 405 410 415 420 424 428 433 438 443 448 453 458 463 468 X 473 478 483 488 493 497 501 506 511 516 521 526 531 536 541 546 551 556 561 566 X 570 574 579 584 589 594 599 604 609 614 619 624 629 634 639 643 647 652 657 662 X 667 672 677 682 687 692 697 702 707 712 716 720 725 730 735 740 745 750 755 760 X 765 770 775 780 785 789 793 798 803 808 813 818 823 828 833 838 843 848 853 858 X 862 866 871 876 881 886 891 896 901 906 911 916 921 926 931 935 939 944 949 954 X 959 964 969 974 979 984 989 994 99910041008101110151019102310271031103510391043 104710511055105910631066 X 1 2 16 1 2 3 17 2 3 4 18 3 4 5 19 4 5 6 20 5 6 7 21 6 7 8 X 22 7 8 9 23 8 9 10 24 9 10 11 25 10 11 12 26 11 12 13 27 12 13 14 28 13 X 14 15 29 14 15 30 1 16 17 31 2 16 17 18 32 3 17 18 19 33 4 18 19 20 34 5 X 19 20 21 35 6 20 21 22 36 7 21 22 23 37 8 22 23 24 38 9 23 24 25 39 10 24 X 25 26 40 11 25 26 27 41 12 26 27 28 42 13 27 28 29 43 14 28 29 30 44 15 29 30 X 45 16 31 32 46 17 31 32 33 47 18 32 33 34 48 19 33 34 35 49 20 34 35 36 50 21 X 35 36 37 51 22 36 37 38 52 23 37 38 39 53 24 38 39 40 54 25 39 40 41 55 26 40 X 41 42 56 27 41 42 43 57 28 42 43 44 58 29 43 44 45 59 30 44 45 60 31 46 47 61 X 32 46 47 48 62 33 47 48 49 63 34 48 49 50 64 35 49 50 51 65 36 50 51 52 66 37 X 51 52 53 67 38 52 53 54 68 39 53 54 55 69 40 54 55 56 70 41 55 56 57 71 42 56 X 57 58 72 43 57 58 59 73 44 58 59 60 74 45 59 60 75 46 61 62 76 47 61 62 63 77 X 48 62 63 64 78 49 63 64 65 79 50 64 65 66 80 51 65 66 67 81 52 66 67 68 82 53 X 67 68 69 83 54 68 69 70 84 55 69 70 71 85 56 70 71 72 86 57 71 72 73 87 58 72 X 73 74 88 59 73 74 75 89 60 74 75 90 61 76 77 91 62 76 77 78 92 63 77 78 79 93 X 64 78 79 80 94 65 79 80 81 95 66 80 81 82 96 67 81 82 83 97 68 82 83 84 98 69 X 83 84 85 99 70 84 85 86100 71 85 86 87101 72 86 87 88102 73 87 88 89103 74 88 X 89 90104 75 89 90105 76 91 92106 77 91 92 93107 78 92 93 94108 79 93 94 95109 X 80 94 95 96110 81 95 96 97111 82 96 97 98112 83 97 98 99113 84 98 99100114 85 X 99100101115 86100101102116 87101102103117 88102103104118 89103104105119 90104 105120 91106107121 92106107108122 93107108109123 94108109110124 95109110111125 X 96110111112126 97111112113127 98112113114128 99113114115129100114115116130101 115116117131102116117118132103117118119133104118119120134105119120135106121122 136107121122123137108122123124138109123124125139110124125126140111125126127141 112126127128142113127128129143114128129130144115129130131145116130131132146117 131132133147118132133134148119133134135149120134135150121136137151122136137138 152123137138139153124138139140154125139140141155126140141142156127141142143157 128142143144158129143144145159130144145146160131145146147161132146147148162133 147148149163134148149150164135149150165136151152166137151152153167138152153154 168139153154155169140154155156170141155156157171142156157158172143157158159173 144158159160174145159160161175146160161162176147161162163177148162163164178149 163164165179150164165180151166167181152166167168182153167168169183154168169170 184155169170171185156170171172186157171172173187158172173174188159173174175189 160174175176190161175176177191162176177178192163177178179193164178179180194165 179180195166181182196167181182183197168182183184198169183184185199170184185186 200171185186187201172186187188202173187188189203174188189190204175189190191205 176190191192206177191192193207178192193194208179193194195209180194195210181196 197211182196197198212183197198199213184198199200214185199200201215186200201202 216187201202203217188202203204218189203204205219190204205206220191205206207221 192206207208222193207208209223194208209210224195209210225196211212197211212213 198212213214199213214215200214215216201215216217202216217218203217218219204218 219220205219220221206220221222207221222223208222223224209223224225210224225 0.36093750000000000D+01-.11171875000000000D+01-.11171875000000000D+01 -.94140625000000000D+000.36093750000000000D+01-.11757812500000000D+01 -.11171875000000000D+01-.88281250000000000D+000.36093750000000000D+01 -.12343750000000000D+01-.11171875000000000D+01-.82421875000000000D+00 0.36093750000000000D+01-.12929687500000000D+01-.11171875000000000D+01 -.76562500000000000D+000.36093750000000000D+01-.13515625000000000D+01 -.11171875000000000D+01-.70703125000000000D+000.36093750000000000D+01 -.14101562500000000D+01-.11171875000000000D+01-.64843750000000000D+00 0.36093750000000000D+01-.14687500000000000D+01-.11171875000000000D+01 -.58984375000000000D+000.36093750000000000D+01-.15273437500000000D+01 -.11171875000000000D+01-.53125000000000000D+000.36093750000000000D+01 -.15859375000000000D+01-.11171875000000000D+01-.47265625000000000D+00 0.36093750000000000D+01-.16445312500000000D+01-.11171875000000000D+01 -.41406250000000000D+000.36093750000000000D+01-.17031250000000000D+01 -.11171875000000000D+01-.35546875000000000D+000.36093750000000000D+01 -.17617187500000000D+01-.11171875000000000D+01-.29687500000000000D+00 0.36093750000000000D+01-.18203125000000000D+01-.11171875000000000D+01 -.23828125000000000D+000.36093750000000000D+01-.18789062500000000D+01 -.11171875000000000D+01-.17968750000000000D+000.36093750000000000D+01 -.11171875000000000D+01-.94140625000000000D+000.36093750000000000D+01 -.11171875000000000D+01-.11757812500000000D+01-.94140625000000000D+00 -.94140625000000000D+000.36093750000000000D+01-.11757812500000000D+01 -.11757812500000000D+01-.94140625000000000D+00-.88281250000000000D+00 0.36093750000000000D+01-.12343750000000000D+01-.11757812500000000D+01 -.94140625000000000D+00-.82421875000000000D+000.36093750000000000D+01 -.12929687500000000D+01-.11757812500000000D+01-.94140625000000000D+00 -.76562500000000000D+000.36093750000000000D+01-.13515625000000000D+01 -.11757812500000000D+01-.94140625000000000D+00-.70703125000000000D+00 0.36093750000000000D+01-.14101562500000000D+01-.11757812500000000D+01 -.94140625000000000D+00-.64843750000000000D+000.36093750000000000D+01 -.14687500000000000D+01-.11757812500000000D+01-.94140625000000000D+00 -.58984375000000000D+000.36093750000000000D+01-.15273437500000000D+01 -.11757812500000000D+01-.94140625000000000D+00-.53125000000000000D+00 0.36093750000000000D+01-.15859375000000000D+01-.11757812500000000D+01 -.94140625000000000D+00-.47265625000000000D+000.36093750000000000D+01 -.16445312500000000D+01-.11757812500000000D+01-.94140625000000000D+00 -.41406250000000000D+000.36093750000000000D+01-.17031250000000000D+01 -.11757812500000000D+01-.94140625000000000D+00-.35546875000000000D+00 0.36093750000000000D+01-.17617187500000000D+01-.11757812500000000D+01 -.94140625000000000D+00-.29687500000000000D+000.36093750000000000D+01 -.18203125000000000D+01-.11757812500000000D+01-.94140625000000000D+00 -.23828125000000000D+000.36093750000000000D+01-.18789062500000000D+01 -.11757812500000000D+01-.94140625000000000D+00-.17968750000000000D+00 0.36093750000000000D+01-.11757812500000000D+01-.88281250000000000D+00 0.36093750000000000D+01-.11171875000000000D+01-.12343750000000000D+01 -.88281250000000000D+00-.94140625000000000D+000.36093750000000000D+01 -.11757812500000000D+01-.12343750000000000D+01-.88281250000000000D+00 -.88281250000000000D+000.36093750000000000D+01-.12343750000000000D+01 -.12343750000000000D+01-.88281250000000000D+00-.82421875000000000D+00 0.36093750000000000D+01-.12929687500000000D+01-.12343750000000000D+01 -.88281250000000000D+00-.76562500000000000D+000.36093750000000000D+01 -.13515625000000000D+01-.12343750000000000D+01-.88281250000000000D+00 -.70703125000000000D+000.36093750000000000D+01-.14101562500000000D+01 -.12343750000000000D+01-.88281250000000000D+00-.64843750000000000D+00 0.36093750000000000D+01-.14687500000000000D+01-.12343750000000000D+01 -.88281250000000000D+00-.58984375000000000D+000.36093750000000000D+01 -.15273437500000000D+01-.12343750000000000D+01-.88281250000000000D+00 -.53125000000000000D+000.36093750000000000D+01-.15859375000000000D+01 -.12343750000000000D+01-.88281250000000000D+00-.47265625000000000D+00 0.36093750000000000D+01-.16445312500000000D+01-.12343750000000000D+01 -.88281250000000000D+00-.41406250000000000D+000.36093750000000000D+01 -.17031250000000000D+01-.12343750000000000D+01-.88281250000000000D+00 -.35546875000000000D+000.36093750000000000D+01-.17617187500000000D+01 -.12343750000000000D+01-.88281250000000000D+00-.29687500000000000D+00 0.36093750000000000D+01-.18203125000000000D+01-.12343750000000000D+01 -.88281250000000000D+00-.23828125000000000D+000.36093750000000000D+01 -.18789062500000000D+01-.12343750000000000D+01-.88281250000000000D+00 -.17968750000000000D+000.36093750000000000D+01-.12343750000000000D+01 -.82421875000000000D+000.36093750000000000D+01-.11171875000000000D+01 -.12929687500000000D+01-.82421875000000000D+00-.94140625000000000D+00 0.36093750000000000D+01-.11757812500000000D+01-.12929687500000000D+01 -.82421875000000000D+00-.88281250000000000D+000.36093750000000000D+01 -.12343750000000000D+01-.12929687500000000D+01-.82421875000000000D+00 -.82421875000000000D+000.36093750000000000D+01-.12929687500000000D+01 -.12929687500000000D+01-.82421875000000000D+00-.76562500000000000D+00 0.36093750000000000D+01-.13515625000000000D+01-.12929687500000000D+01 -.82421875000000000D+00-.70703125000000000D+000.36093750000000000D+01 -.14101562500000000D+01-.12929687500000000D+01-.82421875000000000D+00 -.64843750000000000D+000.36093750000000000D+01-.14687500000000000D+01 -.12929687500000000D+01-.82421875000000000D+00-.58984375000000000D+00 0.36093750000000000D+01-.15273437500000000D+01-.12929687500000000D+01 -.82421875000000000D+00-.53125000000000000D+000.36093750000000000D+01 -.15859375000000000D+01-.12929687500000000D+01-.82421875000000000D+00 -.47265625000000000D+000.36093750000000000D+01-.16445312500000000D+01 -.12929687500000000D+01-.82421875000000000D+00-.41406250000000000D+00 0.36093750000000000D+01-.17031250000000000D+01-.12929687500000000D+01 -.82421875000000000D+00-.35546875000000000D+000.36093750000000000D+01 -.17617187500000000D+01-.12929687500000000D+01-.82421875000000000D+00 -.29687500000000000D+000.36093750000000000D+01-.18203125000000000D+01 -.12929687500000000D+01-.82421875000000000D+00-.23828125000000000D+00 0.36093750000000000D+01-.18789062500000000D+01-.12929687500000000D+01 -.82421875000000000D+00-.17968750000000000D+000.36093750000000000D+01 -.12929687500000000D+01-.76562500000000000D+000.36093750000000000D+01 -.11171875000000000D+01-.13515625000000000D+01-.76562500000000000D+00 -.94140625000000000D+000.36093750000000000D+01-.11757812500000000D+01 -.13515625000000000D+01-.76562500000000000D+00-.88281250000000000D+00 0.36093750000000000D+01-.12343750000000000D+01-.13515625000000000D+01 -.76562500000000000D+00-.82421875000000000D+000.36093750000000000D+01 -.12929687500000000D+01-.13515625000000000D+01-.76562500000000000D+00 -.76562500000000000D+000.36093750000000000D+01-.13515625000000000D+01 -.13515625000000000D+01-.76562500000000000D+00-.70703125000000000D+00 0.36093750000000000D+01-.14101562500000000D+01-.13515625000000000D+01 -.76562500000000000D+00-.64843750000000000D+000.36093750000000000D+01 -.14687500000000000D+01-.13515625000000000D+01-.76562500000000000D+00 -.58984375000000000D+000.36093750000000000D+01-.15273437500000000D+01 -.13515625000000000D+01-.76562500000000000D+00-.53125000000000000D+00 0.36093750000000000D+01-.15859375000000000D+01-.13515625000000000D+01 -.76562500000000000D+00-.47265625000000000D+000.36093750000000000D+01 -.16445312500000000D+01-.13515625000000000D+01-.76562500000000000D+00 -.41406250000000000D+000.36093750000000000D+01-.17031250000000000D+01 -.13515625000000000D+01-.76562500000000000D+00-.35546875000000000D+00 0.36093750000000000D+01-.17617187500000000D+01-.13515625000000000D+01 -.76562500000000000D+00-.29687500000000000D+000.36093750000000000D+01 -.18203125000000000D+01-.13515625000000000D+01-.76562500000000000D+00 -.23828125000000000D+000.36093750000000000D+01-.18789062500000000D+01 -.13515625000000000D+01-.76562500000000000D+00-.17968750000000000D+00 0.36093750000000000D+01-.13515625000000000D+01-.70703125000000000D+00 0.36093750000000000D+01-.11171875000000000D+01-.14101562500000000D+01 -.70703125000000000D+00-.94140625000000000D+000.36093750000000000D+01 -.11757812500000000D+01-.14101562500000000D+01-.70703125000000000D+00 -.88281250000000000D+000.36093750000000000D+01-.12343750000000000D+01 -.14101562500000000D+01-.70703125000000000D+00-.82421875000000000D+00 0.36093750000000000D+01-.12929687500000000D+01-.14101562500000000D+01 -.70703125000000000D+00-.76562500000000000D+000.36093750000000000D+01 -.13515625000000000D+01-.14101562500000000D+01-.70703125000000000D+00 -.70703125000000000D+000.36093750000000000D+01-.14101562500000000D+01 -.14101562500000000D+01-.70703125000000000D+00-.64843750000000000D+00 0.36093750000000000D+01-.14687500000000000D+01-.14101562500000000D+01 -.70703125000000000D+00-.58984375000000000D+000.36093750000000000D+01 -.15273437500000000D+01-.14101562500000000D+01-.70703125000000000D+00 -.53125000000000000D+000.36093750000000000D+01-.15859375000000000D+01 -.14101562500000000D+01-.70703125000000000D+00-.47265625000000000D+00 0.36093750000000000D+01-.16445312500000000D+01-.14101562500000000D+01 -.70703125000000000D+00-.41406250000000000D+000.36093750000000000D+01 -.17031250000000000D+01-.14101562500000000D+01-.70703125000000000D+00 -.35546875000000000D+000.36093750000000000D+01-.17617187500000000D+01 -.14101562500000000D+01-.70703125000000000D+00-.29687500000000000D+00 0.36093750000000000D+01-.18203125000000000D+01-.14101562500000000D+01 -.70703125000000000D+00-.23828125000000000D+000.36093750000000000D+01 -.18789062500000000D+01-.14101562500000000D+01-.70703125000000000D+00 -.17968750000000000D+000.36093750000000000D+01-.14101562500000000D+01 -.64843750000000000D+000.36093750000000000D+01-.11171875000000000D+01 -.14687500000000000D+01-.64843750000000000D+00-.94140625000000000D+00 0.36093750000000000D+01-.11757812500000000D+01-.14687500000000000D+01 -.64843750000000000D+00-.88281250000000000D+000.36093750000000000D+01 -.12343750000000000D+01-.14687500000000000D+01-.64843750000000000D+00 -.82421875000000000D+000.36093750000000000D+01-.12929687500000000D+01 -.14687500000000000D+01-.64843750000000000D+00-.76562500000000000D+00 0.36093750000000000D+01-.13515625000000000D+01-.14687500000000000D+01 -.64843750000000000D+00-.70703125000000000D+000.36093750000000000D+01 -.14101562500000000D+01-.14687500000000000D+01-.64843750000000000D+00 -.64843750000000000D+000.36093750000000000D+01-.14687500000000000D+01 -.14687500000000000D+01-.64843750000000000D+00-.58984375000000000D+00 0.36093750000000000D+01-.15273437500000000D+01-.14687500000000000D+01 -.64843750000000000D+00-.53125000000000000D+000.36093750000000000D+01 -.15859375000000000D+01-.14687500000000000D+01-.64843750000000000D+00 -.47265625000000000D+000.36093750000000000D+01-.16445312500000000D+01 -.14687500000000000D+01-.64843750000000000D+00-.41406250000000000D+00 0.36093750000000000D+01-.17031250000000000D+01-.14687500000000000D+01 -.64843750000000000D+00-.35546875000000000D+000.36093750000000000D+01 -.17617187500000000D+01-.14687500000000000D+01-.64843750000000000D+00 -.29687500000000000D+000.36093750000000000D+01-.18203125000000000D+01 -.14687500000000000D+01-.64843750000000000D+00-.23828125000000000D+00 0.36093750000000000D+01-.18789062500000000D+01-.14687500000000000D+01 -.64843750000000000D+00-.17968750000000000D+000.36093750000000000D+01 -.14687500000000000D+01-.58984375000000000D+000.36093750000000000D+01 -.11171875000000000D+01-.15273437500000000D+01-.58984375000000000D+00 -.94140625000000000D+000.36093750000000000D+01-.11757812500000000D+01 -.15273437500000000D+01-.58984375000000000D+00-.88281250000000000D+00 0.36093750000000000D+01-.12343750000000000D+01-.15273437500000000D+01 -.58984375000000000D+00-.82421875000000000D+000.36093750000000000D+01 -.12929687500000000D+01-.15273437500000000D+01-.58984375000000000D+00 -.76562500000000000D+000.36093750000000000D+01-.13515625000000000D+01 -.15273437500000000D+01-.58984375000000000D+00-.70703125000000000D+00 0.36093750000000000D+01-.14101562500000000D+01-.15273437500000000D+01 -.58984375000000000D+00-.64843750000000000D+000.36093750000000000D+01 -.14687500000000000D+01-.15273437500000000D+01-.58984375000000000D+00 -.58984375000000000D+000.36093750000000000D+01-.15273437500000000D+01 -.15273437500000000D+01-.58984375000000000D+00-.53125000000000000D+00 0.36093750000000000D+01-.15859375000000000D+01-.15273437500000000D+01 -.58984375000000000D+00-.47265625000000000D+000.36093750000000000D+01 -.16445312500000000D+01-.15273437500000000D+01-.58984375000000000D+00 -.41406250000000000D+000.36093750000000000D+01-.17031250000000000D+01 -.15273437500000000D+01-.58984375000000000D+00-.35546875000000000D+00 0.36093750000000000D+01-.17617187500000000D+01-.15273437500000000D+01 -.58984375000000000D+00-.29687500000000000D+000.36093750000000000D+01 -.18203125000000000D+01-.15273437500000000D+01-.58984375000000000D+00 -.23828125000000000D+000.36093750000000000D+01-.18789062500000000D+01 -.15273437500000000D+01-.58984375000000000D+00-.17968750000000000D+00 0.36093750000000000D+01-.15273437500000000D+01-.53125000000000000D+00 0.36093750000000000D+01-.11171875000000000D+01-.15859375000000000D+01 -.53125000000000000D+00-.94140625000000000D+000.36093750000000000D+01 -.11757812500000000D+01-.15859375000000000D+01-.53125000000000000D+00 -.88281250000000000D+000.36093750000000000D+01-.12343750000000000D+01 -.15859375000000000D+01-.53125000000000000D+00-.82421875000000000D+00 0.36093750000000000D+01-.12929687500000000D+01-.15859375000000000D+01 -.53125000000000000D+00-.76562500000000000D+000.36093750000000000D+01 -.13515625000000000D+01-.15859375000000000D+01-.53125000000000000D+00 -.70703125000000000D+000.36093750000000000D+01-.14101562500000000D+01 -.15859375000000000D+01-.53125000000000000D+00-.64843750000000000D+00 0.36093750000000000D+01-.14687500000000000D+01-.15859375000000000D+01 -.53125000000000000D+00-.58984375000000000D+000.36093750000000000D+01 -.15273437500000000D+01-.15859375000000000D+01-.53125000000000000D+00 -.53125000000000000D+000.36093750000000000D+01-.15859375000000000D+01 -.15859375000000000D+01-.53125000000000000D+00-.47265625000000000D+00 0.36093750000000000D+01-.16445312500000000D+01-.15859375000000000D+01 -.53125000000000000D+00-.41406250000000000D+000.36093750000000000D+01 -.17031250000000000D+01-.15859375000000000D+01-.53125000000000000D+00 -.35546875000000000D+000.36093750000000000D+01-.17617187500000000D+01 -.15859375000000000D+01-.53125000000000000D+00-.29687500000000000D+00 0.36093750000000000D+01-.18203125000000000D+01-.15859375000000000D+01 -.53125000000000000D+00-.23828125000000000D+000.36093750000000000D+01 -.18789062500000000D+01-.15859375000000000D+01-.53125000000000000D+00 -.17968750000000000D+000.36093750000000000D+01-.15859375000000000D+01 -.47265625000000000D+000.36093750000000000D+01-.11171875000000000D+01 -.16445312500000000D+01-.47265625000000000D+00-.94140625000000000D+00 0.36093750000000000D+01-.11757812500000000D+01-.16445312500000000D+01 -.47265625000000000D+00-.88281250000000000D+000.36093750000000000D+01 -.12343750000000000D+01-.16445312500000000D+01-.47265625000000000D+00 -.82421875000000000D+000.36093750000000000D+01-.12929687500000000D+01 -.16445312500000000D+01-.47265625000000000D+00-.76562500000000000D+00 0.36093750000000000D+01-.13515625000000000D+01-.16445312500000000D+01 -.47265625000000000D+00-.70703125000000000D+000.36093750000000000D+01 -.14101562500000000D+01-.16445312500000000D+01-.47265625000000000D+00 -.64843750000000000D+000.36093750000000000D+01-.14687500000000000D+01 -.16445312500000000D+01-.47265625000000000D+00-.58984375000000000D+00 0.36093750000000000D+01-.15273437500000000D+01-.16445312500000000D+01 -.47265625000000000D+00-.53125000000000000D+000.36093750000000000D+01 -.15859375000000000D+01-.16445312500000000D+01-.47265625000000000D+00 -.47265625000000000D+000.36093750000000000D+01-.16445312500000000D+01 -.16445312500000000D+01-.47265625000000000D+00-.41406250000000000D+00 0.36093750000000000D+01-.17031250000000000D+01-.16445312500000000D+01 -.47265625000000000D+00-.35546875000000000D+000.36093750000000000D+01 -.17617187500000000D+01-.16445312500000000D+01-.47265625000000000D+00 -.29687500000000000D+000.36093750000000000D+01-.18203125000000000D+01 -.16445312500000000D+01-.47265625000000000D+00-.23828125000000000D+00 0.36093750000000000D+01-.18789062500000000D+01-.16445312500000000D+01 -.47265625000000000D+00-.17968750000000000D+000.36093750000000000D+01 -.16445312500000000D+01-.41406250000000000D+000.36093750000000000D+01 -.11171875000000000D+01-.17031250000000000D+01-.41406250000000000D+00 -.94140625000000000D+000.36093750000000000D+01-.11757812500000000D+01 -.17031250000000000D+01-.41406250000000000D+00-.88281250000000000D+00 0.36093750000000000D+01-.12343750000000000D+01-.17031250000000000D+01 -.41406250000000000D+00-.82421875000000000D+000.36093750000000000D+01 -.12929687500000000D+01-.17031250000000000D+01-.41406250000000000D+00 -.76562500000000000D+000.36093750000000000D+01-.13515625000000000D+01 -.17031250000000000D+01-.41406250000000000D+00-.70703125000000000D+00 0.36093750000000000D+01-.14101562500000000D+01-.17031250000000000D+01 -.41406250000000000D+00-.64843750000000000D+000.36093750000000000D+01 -.14687500000000000D+01-.17031250000000000D+01-.41406250000000000D+00 -.58984375000000000D+000.36093750000000000D+01-.15273437500000000D+01 -.17031250000000000D+01-.41406250000000000D+00-.53125000000000000D+00 0.36093750000000000D+01-.15859375000000000D+01-.17031250000000000D+01 -.41406250000000000D+00-.47265625000000000D+000.36093750000000000D+01 -.16445312500000000D+01-.17031250000000000D+01-.41406250000000000D+00 -.41406250000000000D+000.36093750000000000D+01-.17031250000000000D+01 -.17031250000000000D+01-.41406250000000000D+00-.35546875000000000D+00 0.36093750000000000D+01-.17617187500000000D+01-.17031250000000000D+01 -.41406250000000000D+00-.29687500000000000D+000.36093750000000000D+01 -.18203125000000000D+01-.17031250000000000D+01-.41406250000000000D+00 -.23828125000000000D+000.36093750000000000D+01-.18789062500000000D+01 -.17031250000000000D+01-.41406250000000000D+00-.17968750000000000D+00 0.36093750000000000D+01-.17031250000000000D+01-.35546875000000000D+00 0.36093750000000000D+01-.11171875000000000D+01-.17617187500000000D+01 -.35546875000000000D+00-.94140625000000000D+000.36093750000000000D+01 -.11757812500000000D+01-.17617187500000000D+01-.35546875000000000D+00 -.88281250000000000D+000.36093750000000000D+01-.12343750000000000D+01 -.17617187500000000D+01-.35546875000000000D+00-.82421875000000000D+00 0.36093750000000000D+01-.12929687500000000D+01-.17617187500000000D+01 -.35546875000000000D+00-.76562500000000000D+000.36093750000000000D+01 -.13515625000000000D+01-.17617187500000000D+01-.35546875000000000D+00 -.70703125000000000D+000.36093750000000000D+01-.14101562500000000D+01 -.17617187500000000D+01-.35546875000000000D+00-.64843750000000000D+00 0.36093750000000000D+01-.14687500000000000D+01-.17617187500000000D+01 -.35546875000000000D+00-.58984375000000000D+000.36093750000000000D+01 -.15273437500000000D+01-.17617187500000000D+01-.35546875000000000D+00 -.53125000000000000D+000.36093750000000000D+01-.15859375000000000D+01 -.17617187500000000D+01-.35546875000000000D+00-.47265625000000000D+00 0.36093750000000000D+01-.16445312500000000D+01-.17617187500000000D+01 -.35546875000000000D+00-.41406250000000000D+000.36093750000000000D+01 -.17031250000000000D+01-.17617187500000000D+01-.35546875000000000D+00 -.35546875000000000D+000.36093750000000000D+01-.17617187500000000D+01 -.17617187500000000D+01-.35546875000000000D+00-.29687500000000000D+00 0.36093750000000000D+01-.18203125000000000D+01-.17617187500000000D+01 -.35546875000000000D+00-.23828125000000000D+000.36093750000000000D+01 -.18789062500000000D+01-.17617187500000000D+01-.35546875000000000D+00 -.17968750000000000D+000.36093750000000000D+01-.17617187500000000D+01 -.29687500000000000D+000.36093750000000000D+01-.11171875000000000D+01 -.18203125000000000D+01-.29687500000000000D+00-.94140625000000000D+00 0.36093750000000000D+01-.11757812500000000D+01-.18203125000000000D+01 -.29687500000000000D+00-.88281250000000000D+000.36093750000000000D+01 -.12343750000000000D+01-.18203125000000000D+01-.29687500000000000D+00 -.82421875000000000D+000.36093750000000000D+01-.12929687500000000D+01 -.18203125000000000D+01-.29687500000000000D+00-.76562500000000000D+00 0.36093750000000000D+01-.13515625000000000D+01-.18203125000000000D+01 -.29687500000000000D+00-.70703125000000000D+000.36093750000000000D+01 -.14101562500000000D+01-.18203125000000000D+01-.29687500000000000D+00 -.64843750000000000D+000.36093750000000000D+01-.14687500000000000D+01 -.18203125000000000D+01-.29687500000000000D+00-.58984375000000000D+00 0.36093750000000000D+01-.15273437500000000D+01-.18203125000000000D+01 -.29687500000000000D+00-.53125000000000000D+000.36093750000000000D+01 -.15859375000000000D+01-.18203125000000000D+01-.29687500000000000D+00 -.47265625000000000D+000.36093750000000000D+01-.16445312500000000D+01 -.18203125000000000D+01-.29687500000000000D+00-.41406250000000000D+00 0.36093750000000000D+01-.17031250000000000D+01-.18203125000000000D+01 -.29687500000000000D+00-.35546875000000000D+000.36093750000000000D+01 -.17617187500000000D+01-.18203125000000000D+01-.29687500000000000D+00 -.29687500000000000D+000.36093750000000000D+01-.18203125000000000D+01 -.18203125000000000D+01-.29687500000000000D+00-.23828125000000000D+00 0.36093750000000000D+01-.18789062500000000D+01-.18203125000000000D+01 -.29687500000000000D+00-.17968750000000000D+000.36093750000000000D+01 -.18203125000000000D+01-.23828125000000000D+000.36093750000000000D+01 -.11171875000000000D+01-.18789062500000000D+01-.23828125000000000D+00 -.94140625000000000D+000.36093750000000000D+01-.11757812500000000D+01 -.18789062500000000D+01-.23828125000000000D+00-.88281250000000000D+00 0.36093750000000000D+01-.12343750000000000D+01-.18789062500000000D+01 -.23828125000000000D+00-.82421875000000000D+000.36093750000000000D+01 -.12929687500000000D+01-.18789062500000000D+01-.23828125000000000D+00 -.76562500000000000D+000.36093750000000000D+01-.13515625000000000D+01 -.18789062500000000D+01-.23828125000000000D+00-.70703125000000000D+00 0.36093750000000000D+01-.14101562500000000D+01-.18789062500000000D+01 -.23828125000000000D+00-.64843750000000000D+000.36093750000000000D+01 -.14687500000000000D+01-.18789062500000000D+01-.23828125000000000D+00 -.58984375000000000D+000.36093750000000000D+01-.15273437500000000D+01 -.18789062500000000D+01-.23828125000000000D+00-.53125000000000000D+00 0.36093750000000000D+01-.15859375000000000D+01-.18789062500000000D+01 -.23828125000000000D+00-.47265625000000000D+000.36093750000000000D+01 -.16445312500000000D+01-.18789062500000000D+01-.23828125000000000D+00 -.41406250000000000D+000.36093750000000000D+01-.17031250000000000D+01 -.18789062500000000D+01-.23828125000000000D+00-.35546875000000000D+00 0.36093750000000000D+01-.17617187500000000D+01-.18789062500000000D+01 -.23828125000000000D+00-.29687500000000000D+000.36093750000000000D+01 -.18203125000000000D+01-.18789062500000000D+01-.23828125000000000D+00 -.23828125000000000D+000.36093750000000000D+01-.18789062500000000D+01 -.18789062500000000D+01-.23828125000000000D+00-.17968750000000000D+00 0.36093750000000000D+01-.18789062500000000D+01-.17968750000000000D+00 0.36093750000000000D+01-.11171875000000000D+01-.17968750000000000D+00 -.94140625000000000D+000.36093750000000000D+01-.11757812500000000D+01 -.17968750000000000D+00-.88281250000000000D+000.36093750000000000D+01 -.12343750000000000D+01-.17968750000000000D+00-.82421875000000000D+00 0.36093750000000000D+01-.12929687500000000D+01-.17968750000000000D+00 -.76562500000000000D+000.36093750000000000D+01-.13515625000000000D+01 -.17968750000000000D+00-.70703125000000000D+000.36093750000000000D+01 -.14101562500000000D+01-.17968750000000000D+00-.64843750000000000D+00 0.36093750000000000D+01-.14687500000000000D+01-.17968750000000000D+00 -.58984375000000000D+000.36093750000000000D+01-.15273437500000000D+01 -.17968750000000000D+00-.53125000000000000D+000.36093750000000000D+01 -.15859375000000000D+01-.17968750000000000D+00-.47265625000000000D+00 0.36093750000000000D+01-.16445312500000000D+01-.17968750000000000D+00 -.41406250000000000D+000.36093750000000000D+01-.17031250000000000D+01 -.17968750000000000D+00-.35546875000000000D+000.36093750000000000D+01 -.17617187500000000D+01-.17968750000000000D+00-.29687500000000000D+00 0.36093750000000000D+01-.18203125000000000D+01-.17968750000000000D+00 -.23828125000000000D+000.36093750000000000D+01-.18789062500000000D+01 -.17968750000000000D+00-.17968750000000000D+000.36093750000000000D+01 SHAR_EOF chmod 0600 dble/dat/csr.dat || echo 'restore of dble/dat/csr.dat failed' Wc_c="`wc -c < 'dble/dat/csr.dat'`" test 29298 -eq "$Wc_c" || echo 'dble/dat/csr.dat: original size 29298, current size' "$Wc_c" fi # ============= dble/dat/csrx.dat ============== if test -f 'dble/dat/csrx.dat' -a X"$1" != X"-c"; then echo 'x - skipping dble/dat/csrx.dat (File already exists)' else echo 'x - extracting dble/dat/csrx.dat (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/dat/csrx.dat' && X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 X 0.00000000000000e+00 SHAR_EOF chmod 0600 dble/dat/csrx.dat || echo 'restore of dble/dat/csrx.dat failed' Wc_c="`wc -c < 'dble/dat/csrx.dat'`" test 5400 -eq "$Wc_c" || echo 'dble/dat/csrx.dat: original size 5400, current size' "$Wc_c" fi # ============= dble/dat/csrv.dat ============== if test -f 'dble/dat/csrv.dat' -a X"$1" != X"-c"; then echo 'x - skipping dble/dat/csrv.dat (File already exists)' else echo 'x - extracting dble/dat/csrv.dat (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/dat/csrv.dat' && X 0.17265625000000000E+01 X 0.66796875000000000E+00 X 0.66796875000000000E+00 X 0.66796875000000000E+00 X 0.66796875000000000E+00 X 0.66796875000000000E+00 X 0.66796875000000000E+00 X 0.66796875000000000E+00 X 0.66796875000000000E+00 X 0.66796875000000000E+00 X 0.66796875000000000E+00 X 0.66796875000000000E+00 X 0.66796875000000000E+00 X 0.66796875000000000E+00 X 0.78906250000000000E+00 X 0.66796875000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.26953125000000000E+00 X 0.66796875000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.26953125000000000E+00 X 0.66796875000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.26953125000000000E+00 X 0.66796875000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.26953125000000000E+00 X 0.66796875000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.26953125000000000E+00 X 0.66796875000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.26953125000000000E+00 X 0.66796875000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.26953125000000000E+00 X 0.66796875000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.26953125000000000E+00 X 0.66796875000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.26953125000000000E+00 X 0.66796875000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.26953125000000000E+00 X 0.66796875000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.26953125000000000E+00 X 0.66796875000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.26953125000000000E+00 X 0.66796875000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.39062500000000000E+00 X -0.26953125000000000E+00 X 0.78906250000000000E+00 X -0.26953125000000000E+00 X -0.26953125000000000E+00 X -0.26953125000000000E+00 X -0.26953125000000000E+00 X -0.26953125000000000E+00 X -0.26953125000000000E+00 X -0.26953125000000000E+00 X -0.26953125000000000E+00 X -0.26953125000000000E+00 X -0.26953125000000000E+00 X -0.26953125000000000E+00 X -0.26953125000000000E+00 X -0.26953125000000000E+00 X -0.14843750000000000E+00 SHAR_EOF chmod 0600 dble/dat/csrv.dat || echo 'restore of dble/dat/csrv.dat failed' Wc_c="`wc -c < 'dble/dat/csrv.dat'`" test 5850 -eq "$Wc_c" || echo 'dble/dat/csrv.dat: original size 5850, current size' "$Wc_c" fi # ============= dble/dat/csrw.dat ============== if test -f 'dble/dat/csrw.dat' -a X"$1" != X"-c"; then echo 'x - skipping dble/dat/csrw.dat (File already exists)' else echo 'x - extracting dble/dat/csrw.dat (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/dat/csrw.dat' && X -2.52670612285392693e+00 X -3.12981492764229430e-01 X -5.93617618531314117e-01 X 3.32322161717665654e-01 X 5.58850703293451434e-01 X 8.99883573546131688e-01 X -2.00898855586523289e-01 X -2.33734974678243862e-01 X 1.44990660185244824e+00 X 1.83613202602166203e+00 X -3.82918259160919427e-01 X 1.55082744517634041e-01 X -9.64648249056895501e-01 X 3.87564312898231872e-02 X 7.65458387074111402e-01 X -5.94524007839467128e-01 X 1.30245975190897978e-01 X 3.50135051326026445e-02 X -6.24674138678893653e-01 X -5.39775240747623841e-01 X 1.87995711256766906e+00 X -1.00384945408178328e+00 X -4.97445877674741299e-01 X -1.50439715265068541e+00 X -9.54492989363980443e-02 X 3.96727053727293111e-01 X -5.27114907886174100e-01 X 3.44571055586827601e-01 X -7.23290526415817259e-01 X 1.26819336319292564e+00 X -3.12426582958191153e-02 X 7.78211737167248230e-01 X 2.18048355295766028e+00 X 4.37813681537625787e-01 X 1.33332898358725349e+00 X 2.51078139110859744e-01 X -3.10470908178119731e-01 X -9.23003723808715093e-01 X -3.84775736018752812e-01 X 1.15818057089115922e+00 X 8.62500188414089375e-01 X -1.03470562492749885e+00 X -1.92672883298641989e-01 X -1.29972277987506701e+00 X 3.06595916028863658e-01 X 9.68992176157492779e-01 X -7.47317126758189398e-01 X -2.79602442297918508e+00 X 6.96731553587481622e-01 X 3.20690754366444031e+00 X 5.36007044749823192e-01 X 2.98450535720106380e-01 X 2.84043160995206323e-01 X 9.59664371348601719e-01 X 2.08759311209632337e+00 X 1.52468053170777473e+00 X -1.95260790032330211e-01 X 1.72603158008979921e-02 X 2.46340438601763606e-01 X -8.54484721089849630e-01 X 1.15778270176474307e+00 X 1.61907723250136332e-01 X 1.55706375548542164e+00 X -1.93543855158581107e-01 X 1.65130117445043179e+00 X -1.89877818089584816e+00 X 1.82252476317014889e+00 X -1.51841513419531315e+00 X -1.05107060879933423e+00 X 4.99305134332340902e-02 X -1.45474886952808413e+00 X 4.66545849753955855e-01 X 5.45436841452860643e-01 X 1.32031907308504048e+00 X -4.04494327876404325e-01 X 4.18468509073848915e-01 X 2.47348749631457726e-01 X 7.04110315408186027e-01 X 6.31938853341632800e-01 X -9.92362112719314848e-01 X 1.76670836879512128e+00 X -3.82103635072939263e-01 X -9.11425420031350630e-01 X -9.96089984118210370e-01 X 1.19514263014411903e+00 X -1.59447782443430802e-01 X 2.70402604824876036e+00 X -1.98499915965496987e-01 X -1.41404614026417491e-01 X 4.11267926557380703e-01 X -1.17905965667048696e+00 X -2.77775505971886494e-01 X -1.58105341380234377e+00 X 1.04902234978445863e+00 X 3.02689036171394199e-01 X -1.22650234105829847e+00 X 6.96000950977379157e-02 X -3.96516210293235416e-01 X 1.38880676152053462e+00 X 1.36442229049003072e+00 X 6.58152637292665821e-01 X 4.91313668926088520e-01 X 8.00733701087079197e-01 X -7.67268996676585435e-01 X 3.64419504046212817e-01 X -3.97913854767016573e-01 X 8.64279576409737516e-01 X -1.77618078276664149e-01 X 1.87438052046940795e+00 X 1.72400234691113430e-01 X 1.27174349438397227e+00 X -3.53443679957601356e-02 X -1.50132883642183579e+00 X 3.65373411191592334e-01 X -1.98659856001020180e-01 X -1.38972170325750999e+00 X 2.29327812227314215e-01 X 2.71190236967230214e-01 X -3.66360220282281213e-01 X 1.37696039157049333e+00 X -7.97532756562797762e-01 X -9.36740611780525367e-01 X -2.43346548885311044e-03 X 3.96086165525257827e-01 X -5.08693172275514027e-01 X -2.68285778746197690e-01 X -1.08214045362096933e+00 X 2.01413372029120419e+00 X 1.94403112557593682e+00 X -1.52152941634797623e+00 X 1.93931842629591666e+00 X -8.95840360657292223e-01 X -3.04157582743064425e-01 X 5.55253123177883778e-01 X -3.24246850701504052e-01 X 1.33881436714640256e+00 X 1.22229851347237273e+00 X -1.59597816278255955e+00 X -1.06773032044442528e+00 X -7.59919212299574154e-01 X 4.20988804468648503e-01 X -4.33373058325242422e-01 X 7.06251990240337246e-01 X 2.27856907314768625e-01 X -1.01699185125668268e+00 X 1.39860372563678254e-01 X -7.48088838235888787e-01 X -6.28974933137321557e-01 X 1.39483065417114704e+00 X -1.64769114004944095e+00 X -2.01498584386620427e+00 X 4.91716880786256527e-01 X -1.55497527509081546e+00 X -1.40609080683032323e-01 X 2.44943668795265301e-01 X -2.67458499968963315e-01 X -5.70245479900343022e-01 X -1.87266786888367814e-01 X 1.20855664796684303e+00 X -6.38854660397775276e-01 X 6.05540298516074937e-01 X -6.24480544088507727e-01 X 5.72228121730056660e-01 X -7.24410495952223288e-01 X 1.19219550553089348e+00 X 1.86746737068575697e-01 X 1.59493888226368430e+00 X 3.21307055691724686e-01 X 8.66840733181726275e-01 X 1.29184357610291878e+00 X 4.34312653452442632e-01 X -3.86206929335472016e-01 X -1.12563759811723021e-01 X -9.64333079249251268e-01 X -2.05725119297093961e+00 X 1.49996068326108345e-01 X 5.42037570810973812e-01 X 2.54408816480612421e-01 X -3.07240693819984811e-01 X -4.17111829581745308e-01 X 1.13680483289389689e+00 X 3.91313809093234544e-01 X 1.60514781867489997e+00 X 8.25892307356857591e-01 X 1.47039035572010768e+00 X -1.37890689233989572e+00 X -2.60172069009687479e-01 X 9.94768172763982217e-01 X 1.83403368186402838e+00 X -1.71591031873495248e+00 X 8.69317058746622712e-02 X 1.95567435281059465e+00 X 1.61453769615341497e-01 X -6.28688359125363805e-01 X -1.43882446533843478e+00 X -6.65959685875582436e-02 X 3.73380862806065694e-01 X 2.17314078186247150e-01 X -1.79456822070788363e-01 X 2.56729070095519964e-02 X 6.42066361973081534e-01 X 9.23086649379001090e-01 X -1.55510777372327769e+00 X 6.63594032788892285e-01 X -6.09499611051491308e-01 X 5.65239403309624411e-01 X -6.10781446255285299e-01 X 1.23111146649210634e+00 X 9.94299745127406931e-01 X -8.03474713644618865e-01 X -5.91204478397532762e-01 X 1.69154640779536125e+00 X 9.53355517329613988e-01 X -1.93005493739851142e+00 X 5.12844987283965770e-01 X 3.93682448572880705e-01 X -9.05426500446262272e-01 X -1.27447327679614819e+00 X 3.46546103379725356e-01 X -1.19523544023497297e+00 X 6.67201442318699822e-01 X -6.77937745985269097e-02 X -1.73566010510706481e+00 X 8.06348573332824392e-01 X -9.14800737775520956e-01 SHAR_EOF chmod 0600 dble/dat/csrw.dat || echo 'restore of dble/dat/csrw.dat failed' Wc_c="`wc -c < 'dble/dat/csrw.dat'`" test 5850 -eq "$Wc_c" || echo 'dble/dat/csrw.dat: original size 5850, current size' "$Wc_c" fi # ============= dble/dns/cpyrit.doc ============== if test ! -d 'dble/dns'; then echo 'x - creating directory dble/dns' mkdir 'dble/dns' fi if test -f 'dble/dns/cpyrit.doc' -a X"$1" != X"-c"; then echo 'x - skipping dble/dns/cpyrit.doc (File already exists)' else echo 'x - extracting dble/dns/cpyrit.doc (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/dns/cpyrit.doc' && C********************************************************************** C C Copyright (C) 1991 Roland W. Freund and Noel M. Nachtigal C All rights reserved. C C This code is provided "as is", without any warranty of any kind, C either expressed or implied, including but not limited to, any C implied warranty of merchantibility or fitness for any purpose. C In no event will any party who distributed the code be liable for C damages or for any claim(s) by any other party, including but not C limited to, any lost profits, lost monies, lost data or data C rendered inaccurate, losses sustained by third parties, or any C other special, incidental or consequential damages arising out of C the use or inability to use the program, even if the possibility C of such damages has been advised against. The entire risk as to C the quality, the performance, and the fitness of the program for C any particular purpose lies with the party using the code. C C No derivative of this code may be used in a commercial package C without the prior explicit written permission of all authors or C their legal proxies. Verbatim copies of this code may be made and C distributed in any medium, provided that this copyright notice C is not removed or altered in any way. No fees may be charged for C distribution of the codes, other than a fee to cover the cost of C the media and a reasonable handling fee. C C********************************************************************** SHAR_EOF chmod 0600 dble/dns/cpyrit.doc || echo 'restore of dble/dns/cpyrit.doc failed' Wc_c="`wc -c < 'dble/dns/cpyrit.doc'`" test 1579 -eq "$Wc_c" || echo 'dble/dns/cpyrit.doc: original size 1579, current size' "$Wc_c" fi # ============= dble/dns/ddlssor.f ============== if test -f 'dble/dns/ddlssor.f' -a X"$1" != X"-c"; then echo 'x - skipping dble/dns/ddlssor.f (File already exists)' else echo 'x - extracting dble/dns/ddlssor.f (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/dns/ddlssor.f' && C********************************************************************** C C Copyright (C) 1991 Roland W. Freund and Noel M. Nachtigal C All rights reserved. C C This code is part of a copyrighted package. For details, see the C file `cpyrit.doc' in the current directory. C C ***************************************************************** C ANY USE OF THIS CODE CONSTITUES ACCEPTANCE OF THE TERMS OF THE C COPYRIGHT NOTICE C ***************************************************************** C C********************************************************************** C C These are the preconditioner routines for the SSOR preconditioner C applied on the left, dense matrices. C C There are four routines: C M1I (X,Y) - computes X = M_1^{-1} * X, Y a work vector; C M1T (X,Y) - computes X = M_1^{-T} * X, Y a work vector; C M2I (X,Y) - computes X = M_2^{-1} * X, Y a work vector; C M2T (X,Y) - computes X = M_2^{-T} * X, Y a work vector. C PSETUP - sets up the preconditioner (empty for SSOR). C C For the SSOR preconditioner, C M = M_1 * M_2 = ( D + w L ) D^{-1} ( D + w U ), C where C A = D + L + U. C C For left preconditioning, M_2 = I. C C External routines used: C subroutine daxpy(n,da,dx,incx,dy,incy) C Computes dy = da * dx + dy. C subroutine dcopy(n,dx,incx,dy,incy) C Computes dy = dx. C double precision ddot(n,dx,incx,dy,incy) C Computes the dot product of dx and dy. C C Noel M. Nachtigal C October 23, 1990 C C********************************************************************** C X SUBROUTINE M1I(X,Y) C X DOUBLE PRECISION X(*), Y(*) C X INCLUDE 'dimblk.inc' X INCLUDE 'dns.inc' C C SSOR parameter OMEGA. C X DOUBLE PRECISION OMEGA X COMMON /OMG/OMEGA C C Local variables. C X INTEGER I X DOUBLE PRECISION DTMP C C If the SSOR parameter is not initialized, initialize it. C X IF (OMEGA.EQ.-1.0) THEN X WRITE (6,'(A31,$)') 'Enter SSOR parameter OMEGA : ' X READ (5,*) OMEGA X ENDIF C C Multiply by D * ( D + w L )^{-1}. C X DO 10 I = 1, NROW X DTMP = -OMEGA * X(I) * AINV(I) X CALL DAXPY(NROW-I,DTMP,A(I+1,I),1,X(I+1),1) X 10 CONTINUE C C Multiply by ( D + w U )^{-1}. C X DO 20 I = NROW, 1, -1 X X(I) = X(I) * AINV(I) X DTMP = -OMEGA * X(I) X CALL DAXPY(I-1,DTMP,A(1,I),1,X,1) X 20 CONTINUE C X RETURN X END C C********************************************************************** C X SUBROUTINE M1T(X,Y) C X EXTERNAL DDOT X DOUBLE PRECISION DDOT C X DOUBLE PRECISION X(*), Y(*) C X INCLUDE 'dimblk.inc' X INCLUDE 'dns.inc' C C SSOR parameter OMEGA. C X DOUBLE PRECISION OMEGA X COMMON /OMG/OMEGA C C Local variables. C X INTEGER I X DOUBLE PRECISION DTMP C C If the SSOR parameter is not initialized, initialize it. C X IF (OMEGA.EQ.-1.0) THEN X WRITE (6,'(A31,$)') 'Enter SSOR parameter OMEGA : ' X READ (5,*) OMEGA X ENDIF C C Multiply by ( D + w U )^{-T}. C X CALL DCOPY(NROW,X,1,Y,1) X DO 10 I = 1, NROW X DTMP = DDOT(I-1,A(1,I),1,Y,1) X Y(I) = ( Y(I) - OMEGA * DTMP ) * AINV(I) X 10 CONTINUE C C Multiply by ( D + w L )^{-T} * D. C X DO 20 I = NROW, 1, -1 X DTMP = DDOT(NROW-I,A(I+1,I),1,X(I+1),1) X X(I) = Y(I) - OMEGA * DTMP * AINV(I) X 20 CONTINUE C X RETURN X END C C********************************************************************** C X SUBROUTINE M2I(X,Y) C X DOUBLE PRECISION X(*), Y(*) C X RETURN X END C C********************************************************************** C X SUBROUTINE M2T(X,Y) C X DOUBLE PRECISION X(*), Y(*) C X RETURN X END C C********************************************************************** C X SUBROUTINE PSETUP C C Purpose: C This subroutine sets up the preconditioner. We store the diagonal C elements inverted in AINV. This also checks for small diagonals, C where small is relative to the 1-norm of the row and column. If C a small diagonal is found, PRECON is set to -1. C C External routines used: C double precision dadd(dx,dy) C Computes dx + dy. Used to get around optimizers. C double precision dasum(n,dx,incx) C Computes the 1-norm of dx. C C Noel M. Nachtigal C October 31, 1990 C X INTRINSIC MAX X EXTERNAL DADD, DASUM X DOUBLE PRECISION DADD, DASUM C X INCLUDE 'dimblk.inc' X INCLUDE 'dns.inc' C X INTEGER I X DOUBLE PRECISION DA, DNRM, DTMP C C Store the inverted diagonals. Check for small diagonal elements. C X DO 10 I = 1, NROW X DA = A(I,I) X DNRM = MAX(DASUM(NROW,A(1,I),1),DASUM(NROW,A(I,1),NDIM)) X DTMP = DADD(DNRM,DA) X IF (DA.NE.0.0) AINV(I) = 1.0 / DA X IF (DTMP.EQ.DNRM) THEN X WRITE (6,'(A30,I5,E25.18)') 'Small diagonal on row:', I, DA X PRECON = -1 X END IF X 10 CONTINUE C X RETURN X END C C********************************************************************** C X BLOCK DATA C C Purpose: C This sets the SSOR parameter OMEGA to -1, the preconditioner name C to 'DENSE SSOR (LEFT)'. C C Noel M. Nachtigal C October 23, 1990 C X INCLUDE 'dimblk.inc' X INCLUDE 'precon.inc' X INCLUDE 'dns.inc' C X DOUBLE PRECISION OMEGA X COMMON /OMG/OMEGA C X DATA OMEGA/-1.0/ X DATA PNAME/'DENSE SSOR (LEFT)'/ C X END C C********************************************************************** SHAR_EOF chmod 0600 dble/dns/ddlssor.f || echo 'restore of dble/dns/ddlssor.f failed' Wc_c="`wc -c < 'dble/dns/ddlssor.f'`" test 5671 -eq "$Wc_c" || echo 'dble/dns/ddlssor.f: original size 5671, current size' "$Wc_c" fi # ============= dble/dns/ddns.f ============== if test -f 'dble/dns/ddns.f' -a X"$1" != X"-c"; then echo 'x - skipping dble/dns/ddns.f (File already exists)' else echo 'x - extracting dble/dns/ddns.f (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/dns/ddns.f' && C********************************************************************** C C Copyright (C) 1991 Roland W. Freund and Noel M. Nachtigal C All rights reserved. C C This code is part of a copyrighted package. For details, see the C file `cpyrit.doc' in the current directory. C C ***************************************************************** C ANY USE OF THIS CODE CONSTITUES ACCEPTANCE OF THE TERMS OF THE C COPYRIGHT NOTICE C ***************************************************************** C C********************************************************************** C C This file contains support routines for dense matrices. The C following routines are in this file: C C SUBROUTINE AXB (X,B) C Computes B = A * X. A is preconditioned. C SUBROUTINE ATXB (X,B) C Computes B = A^T * X. A is preconditioned. C SUBROUTINE GETMAT C Reads in a dense matrix. C DOUBLE PRECISION FUNCTION GETNRM() C Returns an estimate for the norm of the matrix based on using C Gershgorin disks. C C********************************************************************** C X SUBROUTINE AXB (X,B) C C Purpose: C This subroutine computes B = A * X for a dense matrix A. The code C assumes that A is preconditioned to M_1^{-1} A M_2^{-1}. C C Parameters: C X = the vector to be multiplied by A (input). C B = the result of the multiplication (output). C C External routines used: C subroutine daxpy(n,da,dx,incx,dy,incxy) C Computes dy = da * dx + dy. C subroutine dcopy(n,dx,incx,dy,incy) C Computes dy = dx. C subroutine dscal(n,da,dx,incx) C Computes dx = da * dx. C subroutine m1i(x,y) C Computes x = M_1^{-1} * x. C subroutine m2i(x,y) C Computes x = M_2^{-1} * x. C C Noel M. Nachtigal C October 1, 1990 C X DOUBLE PRECISION B(*), X(*) C X INCLUDE 'dimblk.inc' X INCLUDE 'dns.inc' C C Local variables. C X INTEGER I C C Copy X to the local vector. C X CALL DCOPY (NROW,X,1,XTMP,1) C C Multiply by preconditioner matrix M_2^{-1}. C X IF (PRECON.EQ.1) CALL M2I (XTMP,B) C C Multiply by A. C X CALL DCOPY (NROW,A,1,B,1) X CALL DSCAL (NROW,XTMP(1),B,1) X DO 10 I = 2, NROW X CALL DAXPY (NROW,XTMP(I),A(1,I),1,B,1) X 10 CONTINUE C C Multiply by preconditioner matrix M_1^{-1}. C X IF (PRECON.EQ.1) CALL M1I (B,XTMP) C X RETURN X END C C********************************************************************** C X SUBROUTINE ATXB (X,B) C C Purpose: C This subroutine computes B = A^T * X for a dense matrix A. The C code assumes that A is preconditioned to M_1^{-1} A M_2^{-1}. C C Parameters: C X = the vector to be multiplied by A (input). C B = the result of the multiplication (output). C C External routines used: C subroutine dcopy(n,dx,incx,dy,incy) C Sets dy = dx. C double precision ddot(n,dx,incx,dy,incy) C Computes the dot product of dx and dy. C subroutine m1t(x,y) C Computes x = M_1^{-T} * x. C subroutine m2t(x,y) C Computes x = M_2^{-T} * x. C C Noel M. Nachtigal C October 1, 1990 C X EXTERNAL DDOT X DOUBLE PRECISION DDOT C X DOUBLE PRECISION B(*), X(*) C X INCLUDE 'dimblk.inc' X INCLUDE 'dns.inc' C C Local variables. C X INTEGER I C C Copy X to the local vector. C X CALL DCOPY (NROW,X,1,XTMP,1) C C Multiply by preconditioner matrix M_1^{-T}. C X IF (PRECON.EQ.1) CALL M1T (XTMP,B) C C Multiply by A. C X DO 10 I = 1, NROW X B(I) = DDOT(NROW,A(1,I),1,XTMP,1) X 10 CONTINUE C C Multiply by preconditioner matrix M_2^{-T}. C X IF (PRECON.EQ.1) CALL M2T (B,XTMP) C X RETURN X END C C********************************************************************** C X SUBROUTINE GETMAT C C Purpose: C This subroutine initializes the matrix by reading it from a user- C specified ASCII data file. The first line of the file contains an C integer specifying the dimension NROW of the matrix, followed by C the matrix entries, listed row by row, i.e., A(1,1), A(1,2), .... C C Noel M. Nachtigal C October 1, 1990 C X INCLUDE 'dimblk.inc' X INCLUDE 'dns.inc' C C Local variables. C X CHARACTER NAME*72 X INTEGER I, J C C Get the data file from the user. C X WRITE (6,'(A30,$)') 'Enter dense matrix file name: ' X READ (5,'(A72)') NAME C C Open the file. C X OPEN (10,FILE=NAME) C C Read the matrix dimension. C X READ (10,'(I10)') NCOL C C Our matrices are square. C X NROW = NCOL C C Output the matrix parameters. C X WRITE (6,'(A7,I10)') 'NDIM : ', NDIM X WRITE (6,'(A7,I10)') 'NROW : ', NROW X WRITE (6,'(A7,I10)') 'NCOL : ', NCOL C C Check that it isn't too big. C X IF (NCOL.GT.NDIM) THEN X WRITE (6,'(A36)') 'Matrix dimension exceeds allocation.' X STOP X ENDIF C C Read in the matrix. C X DO 10 I = 1, NROW X READ (10,*) (A(I,J),J=1,NCOL) X 10 CONTINUE X CLOSE (10) C X RETURN X END C C********************************************************************** C X DOUBLE PRECISION FUNCTION GETNRM() C C Purpose: C This function returns an estimate for the norm of the matrix. The C current estimate is based on Gershgorin disks. C C External routines used: C double precision function dnrm1(n,x,incx) C Computes the 1-norm of a vector. C C Noel M. Nachtigal C October 1, 1990 C X EXTERNAL DASUM X DOUBLE PRECISION DASUM X INTRINSIC MAX, MIN C X INCLUDE 'dimblk.inc' X INCLUDE 'dns.inc' C C Local variables. C X INTEGER I X DOUBLE PRECISION DTMP1, DTMP2 C C Get the maximum column norm. C X DTMP1 = 0.0 X DO 10 I = 1, NCOL X DTMP1 = MAX(DTMP1,DASUM(NROW,A(1,I),1)) X 10 CONTINUE C C Get the maximum row norm. C X DTMP2 = 0.0 X DO 20 I = 1, NROW X DTMP2 = MAX(DTMP2,DASUM(NCOL,A(I,1),NDIM)) X 20 CONTINUE C C Get the smallest of the two. C X GETNRM = MIN(DTMP1,DTMP2) C X RETURN X END C C********************************************************************** SHAR_EOF chmod 0600 dble/dns/ddns.f || echo 'restore of dble/dns/ddns.f failed' Wc_c="`wc -c < 'dble/dns/ddns.f'`" test 6294 -eq "$Wc_c" || echo 'dble/dns/ddns.f: original size 6294, current size' "$Wc_c" fi # ============= dble/dns/ddrssor.f ============== if test -f 'dble/dns/ddrssor.f' -a X"$1" != X"-c"; then echo 'x - skipping dble/dns/ddrssor.f (File already exists)' else echo 'x - extracting dble/dns/ddrssor.f (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/dns/ddrssor.f' && C********************************************************************** C C Copyright (C) 1991 Roland W. Freund and Noel M. Nachtigal C All rights reserved. C C This code is part of a copyrighted package. For details, see the C file `cpyrit.doc' in the current directory. C C ***************************************************************** C ANY USE OF THIS CODE CONSTITUES ACCEPTANCE OF THE TERMS OF THE C COPYRIGHT NOTICE C ***************************************************************** C C********************************************************************** C C These are the preconditioner routines for the SSOR preconditioner C applied on the right, dense matrices. C C There are four routines: C M1I (X,Y) - computes X = M_1^{-1} * X, Y a work vector; C M1T (X,Y) - computes X = M_1^{-T} * X, Y a work vector; C M2I (X,Y) - computes X = M_2^{-1} * X, Y a work vector; C M2T (X,Y) - computes X = M_2^{-T} * X, Y a work vector. C PSETUP - sets up the preconditioner (empty for SSOR). C C For the SSOR preconditioner, C M = M_1 * M_2 = ( D + w L ) D^{-1} ( D + w U ), C where C A = D + L + U. C C For right preconditioning, M_1 = I. C C External routines used: C subroutine daxpy(n,da,dx,incx,dy,incy) C Computes dy = da * dx + dy. C double precision ddot(n,dx,incx,dy,incy) C Computes the dot product of dx and dy. C C Noel M. Nachtigal C October 23, 1990 C C********************************************************************** C X SUBROUTINE M1I(X,Y) C X DOUBLE PRECISION X(*), Y(*) C X RETURN X END C C********************************************************************** C X SUBROUTINE M1T(X,Y) C X DOUBLE PRECISION X(*), Y(*) C X RETURN X END C C********************************************************************** C X SUBROUTINE M2I(X,Y) C X DOUBLE PRECISION X(*), Y(*) C X INCLUDE 'dimblk.inc' X INCLUDE 'dns.inc' C C SSOR parameter OMEGA. C X DOUBLE PRECISION OMEGA X COMMON /OMG/OMEGA C C Local variables. C X INTEGER I X DOUBLE PRECISION DTMP C C If the SSOR parameter is not initialized, initialize it. C X IF (OMEGA.EQ.-1.0) THEN X WRITE (6,'(A31,$)') 'Enter SSOR parameter OMEGA : ' X READ (5,*) OMEGA X ENDIF C C Multiply by D * ( D + w L )^{-1}. C X DO 10 I = 1, NROW X DTMP = -OMEGA * X(I) * AINV(I) X CALL DAXPY(NROW-I,DTMP,A(I+1,I),1,X(I+1),1) X 10 CONTINUE C C Multiply by ( D + w U )^{-1}. C X DO 20 I = NROW, 1, -1 X X(I) = X(I) * AINV(I) X DTMP = -OMEGA * X(I) X CALL DAXPY(I-1,DTMP,A(1,I),1,X,1) X 20 CONTINUE C X RETURN X END C C********************************************************************** C X SUBROUTINE M2T(X,Y) C X EXTERNAL DDOT X DOUBLE PRECISION DDOT C X DOUBLE PRECISION X(*), Y(*) C X INCLUDE 'dimblk.inc' X INCLUDE 'dns.inc' C C SSOR parameter OMEGA. C X DOUBLE PRECISION OMEGA X COMMON /OMG/OMEGA C C Local variables. C X INTEGER I X DOUBLE PRECISION DTMP C C If the SSOR parameter is not initialized, initialize it. C X IF (OMEGA.EQ.-1.0) THEN X WRITE (6,'(A31,$)') 'Enter SSOR parameter OMEGA : ' X READ (5,*) OMEGA X ENDIF C C Multiply by ( D + w U )^{-T}. C X DO 10 I = 1, NROW X DTMP = DDOT(I-1,A(1,I),1,X,1) X X(I) = ( X(I) - OMEGA * DTMP ) * AINV(I) X 10 CONTINUE C C Multiply by ( D + w L )^{-T} * D. C X DO 20 I = NROW, 1, -1 X DTMP = DDOT(NROW-I,A(I+1,I),1,X(I+1),1) X X(I) = X(I) - OMEGA * DTMP * AINV(I) X 20 CONTINUE C X RETURN X END C C********************************************************************** C X SUBROUTINE PSETUP C C Purpose: C This subroutine sets up the preconditioner. We store the diagonal C elements inverted in AINV. This also checks for small diagonals, C where small is relative to the 1-norm of the row and column. If C a small diagonal is found, PRECON is set to -1. C C External routines used: C double precision dadd(dx,dy) C Computes dx + dy. Used to get around optimizers. C double precision dasum(n,dx,incx) C Computes the 1-norm of dx. C C Noel M. Nachtigal C October 31, 1990 C X INTRINSIC MAX X EXTERNAL DADD, DASUM X DOUBLE PRECISION DADD, DASUM C X INCLUDE 'dimblk.inc' X INCLUDE 'dns.inc' C X INTEGER I X DOUBLE PRECISION DA, DNRM, DTMP C C Store the inverted diagonals. Check for small diagonal elements. C X DO 10 I = 1, NROW X DA = A(I,I) X DNRM = MAX(DASUM(NROW,A(1,I),1),DASUM(NROW,A(I,1),NDIM)) X DTMP = DADD(DNRM,DA) X IF (DA.NE.0.0) AINV(I) = 1.0 / DA X IF (DTMP.EQ.DNRM) THEN X WRITE (6,'(A30,I5,E25.18)') 'Small diagonal on row:', I, DA X PRECON = -1 X END IF X 10 CONTINUE C X RETURN X END C C********************************************************************** C X BLOCK DATA C C Purpose: C This sets the SSOR parameter OMEGA to -1, the preconditioner name C to 'DENSE SSOR (RIGHT)'. C C Noel M. Nachtigal C October 23, 1990 C X INCLUDE 'dimblk.inc' X INCLUDE 'precon.inc' X INCLUDE 'dns.inc' C X DOUBLE PRECISION OMEGA X COMMON /OMG/OMEGA C X DATA OMEGA/-1.0/ X DATA PNAME/'DENSE SSOR (RIGHT)'/ C X END C C********************************************************************** SHAR_EOF chmod 0600 dble/dns/ddrssor.f || echo 'restore of dble/dns/ddrssor.f failed' Wc_c="`wc -c < 'dble/dns/ddrssor.f'`" test 5575 -eq "$Wc_c" || echo 'dble/dns/ddrssor.f: original size 5575, current size' "$Wc_c" fi # ============= dble/dns/dns.inc ============== if test -f 'dble/dns/dns.inc' -a X"$1" != X"-c"; then echo 'x - skipping dble/dns/dns.inc (File already exists)' else echo 'x - extracting dble/dns/dns.inc (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/dns/dns.inc' && C********************************************************************** C C Copyright (C) 1991 Roland W. Freund and Noel M. Nachtigal C All rights reserved. C C This code is part of a copyrighted package. For details, see the C file `cpyrit.doc' in the current directory. C C ***************************************************************** C ANY USE OF THIS CODE CONSTITUES ACCEPTANCE OF THE TERMS OF THE C COPYRIGHT NOTICE C ***************************************************************** C C********************************************************************** C C Common block ABLK. C X DOUBLE PRECISION A(NDIM,NDIM), AINV(NDIM), XTMP(NDIM) X COMMON /ABLK/A, AINV, XTMP SHAR_EOF chmod 0600 dble/dns/dns.inc || echo 'restore of dble/dns/dns.inc failed' Wc_c="`wc -c < 'dble/dns/dns.inc'`" test 750 -eq "$Wc_c" || echo 'dble/dns/dns.inc: original size 750, current size' "$Wc_c" fi # ============= dble/dns/makefile ============== if test -f 'dble/dns/makefile' -a X"$1" != X"-c"; then echo 'x - skipping dble/dns/makefile (File already exists)' else echo 'x - extracting dble/dns/makefile (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/dns/makefile' && #********************************************************************** # # Copyright (C) 1991 Roland W. Freund and Noel M. Nachtigal # All rights reserved. # # This code is part of a copyrighted package. For details, see the # file `cpyrit.doc' in the current directory. # # ***************************************************************** # ANY USE OF THIS CODE CONSTITUES ACCEPTANCE OF THE TERMS OF THE # COPYRIGHT NOTICE # ***************************************************************** # #********************************************************************** # # Makefile for the dense matrix subdirectory. # # Files in this directory: # INC = dimblk.inc precon.inc FOR = OBJ = ddlssor.o ddns.o ddrssor.o ddnspr.o SRC = ddlssor.f ddns.f ddrssor.f dns.inc X # # Include here the skeleton makefile. # include ../skeleton.mak include ../local.mak X # # Additional targets in this directory. # dlssor: ddlssor.o X @$(CP) ddlssor.o ddnspr.o X @$(ECHO) Dense left SSOR preconditioner set up, now recompile. X X drssor: ddrssor.o X @$(CP) ddrssor.o ddnspr.o X @$(ECHO) Dense right SSOR preconditioner set up, now recompile. X # # This is the local help target. # lochelp: X @$(ECHO) " drssor - set up dense SSOR right preconditioner" X @$(ECHO) " dlssor - set up dense SSOR left preconditioner" X # # Dependencies for files in this directory. # ddlssor.o: ddlssor.f dns.inc dimblk.inc precon.inc X ddns.o: ddns.f dns.inc dimblk.inc X ddrssor.o: ddrssor.f dns.inc dimblk.inc precon.inc X ddnspr.o: ddrssor.o X @$(CP) ddrssor.o ddnspr.o SHAR_EOF chmod 0600 dble/dns/makefile || echo 'restore of dble/dns/makefile failed' Wc_c="`wc -c < 'dble/dns/makefile'`" test 1600 -eq "$Wc_c" || echo 'dble/dns/makefile: original size 1600, current size' "$Wc_c" fi # ============= dble/inc/dimblk.inc ============== if test ! -d 'dble/inc'; then echo 'x - creating directory dble/inc' mkdir 'dble/inc' fi if test -f 'dble/inc/dimblk.inc' -a X"$1" != X"-c"; then echo 'x - skipping dble/inc/dimblk.inc (File already exists)' else echo 'x - extracting dble/inc/dimblk.inc (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/inc/dimblk.inc' && C********************************************************************** C C Common block DIMBLK. C X INTEGER NDIM X PARAMETER (NDIM=250) C X INTEGER NCOL, NROW, PRECON X COMMON /DIMBLK/NCOL, NROW, PRECON SHAR_EOF chmod 0600 dble/inc/dimblk.inc || echo 'restore of dble/inc/dimblk.inc failed' Wc_c="`wc -c < 'dble/inc/dimblk.inc'`" test 224 -eq "$Wc_c" || echo 'dble/inc/dimblk.inc: original size 224, current size' "$Wc_c" fi # ============= dble/inc/precon.inc ============== if test -f 'dble/inc/precon.inc' -a X"$1" != X"-c"; then echo 'x - skipping dble/inc/precon.inc (File already exists)' else echo 'x - extracting dble/inc/precon.inc (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/inc/precon.inc' && C********************************************************************** C C Common block PRCNAM. C X CHARACTER*40 PNAME X COMMON /PRCNAM/PNAME SHAR_EOF chmod 0600 dble/inc/precon.inc || echo 'restore of dble/inc/precon.inc failed' Wc_c="`wc -c < 'dble/inc/precon.inc'`" test 155 -eq "$Wc_c" || echo 'dble/inc/precon.inc: original size 155, current size' "$Wc_c" fi # ============= dble/lal/cpyrit.doc ============== if test ! -d 'dble/lal'; then echo 'x - creating directory dble/lal' mkdir 'dble/lal' fi if test -f 'dble/lal/cpyrit.doc' -a X"$1" != X"-c"; then echo 'x - skipping dble/lal/cpyrit.doc (File already exists)' else echo 'x - extracting dble/lal/cpyrit.doc (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/lal/cpyrit.doc' && C********************************************************************** C C Copyright (C) 1991 Roland W. Freund and Noel M. Nachtigal C All rights reserved. C C This code is provided "as is", without any warranty of any kind, C either expressed or implied, including but not limited to, any C implied warranty of merchantibility or fitness for any purpose. C In no event will any party who distributed the code be liable for C damages or for any claim(s) by any other party, including but not C limited to, any lost profits, lost monies, lost data or data C rendered inaccurate, losses sustained by third parties, or any C other special, incidental or consequential damages arising out of C the use or inability to use the program, even if the possibility C of such damages has been advised against. The entire risk as to C the quality, the performance, and the fitness of the program for C any particular purpose lies with the party using the code. C C No derivative of this code may be used in a commercial package C without the prior explicit written permission of all authors or C their legal proxies. Verbatim copies of this code may be made and C distributed in any medium, provided that this copyright notice C is not removed or altered in any way. No fees may be charged for C distribution of the codes, other than a fee to cover the cost of C the media and a reasonable handling fee. C C********************************************************************** SHAR_EOF chmod 0600 dble/lal/cpyrit.doc || echo 'restore of dble/lal/cpyrit.doc failed' Wc_c="`wc -c < 'dble/lal/cpyrit.doc'`" test 1579 -eq "$Wc_c" || echo 'dble/lal/cpyrit.doc: original size 1579, current size' "$Wc_c" fi # ============= dble/lal/dcoeff.f ============== if test -f 'dble/lal/dcoeff.f' -a X"$1" != X"-c"; then echo 'x - skipping dble/lal/dcoeff.f (File already exists)' else echo 'x - extracting dble/lal/dcoeff.f (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/lal/dcoeff.f' && C********************************************************************** C C Copyright (C) 1991 Roland W. Freund and Noel M. Nachtigal C All rights reserved. C C This code is part of a copyrighted package. For details, see the C file `cpyrit.doc' in the current directory. C C ***************************************************************** C ANY USE OF THIS CODE CONSTITUES ACCEPTANCE OF THE TERMS OF THE C COPYRIGHT NOTICE C ***************************************************************** C C********************************************************************** C C This file contains the coefficient functions used by the Lanczos C algorithm in the recursion formulas for the inner vectors. The C basic recursions are of the form: C C V_{N+1} = A * V_N - ZETA_{N-N_K} * V_N - ETA_{N-N_K} * V_{N-1} C W_{N+1} = A^T * W_N - ZETA_{N-N_K} * W_N - ETA_{N-N_K} * W_{N-1} C C The functions in this file compute the coefficients ZETA_N and C ETA_N for the various indices N-N_K. Note that the indices start C at 0. C C********************************************************************** C X DOUBLE PRECISION FUNCTION DETA(I) C C Purpose: C Returns the second scalar in the recursion for inner vectors. The C formulas given here are for Chebyshev poynomials, unless DCHEB is C zero, in which case DETA(I) = 1.0. C Note: DETA(0) *must* return 0.0. C C Parameters: C I = the degree of the current polynomial, see above (input). C C Noel M. Nachtigal C August 28, 1990 C X INTEGER I C X DOUBLE PRECISION DCHEB, CCHEB X COMMON /CHEBY/DCHEB, CCHEB C X IF (I.LE.0) THEN X DETA = 0.0D0 X ELSE IF (DCHEB.EQ.0.0D0) THEN X DETA = 1.0D0 X ELSE IF (I.EQ.1) THEN X DETA = 0.5D0 * CCHEB X ELSE X DETA = 0.25D0 * CCHEB X END IF C X RETURN X END C C********************************************************************** C X DOUBLE PRECISION FUNCTION DZETA(I) C C Purpose: C Returns the first scalar in the recursion for inner vectors. The C formulas given here are for Chebyshev poynomials, unless DCHEB is C zero, in which case DZETA(I) = 1.0. C C Parameters: C I = the degree of the current polynomial, as above (input). C C Noel M. Nachtigal C August 28, 1990 X X INTEGER I C X DOUBLE PRECISION DCHEB, CCHEB X COMMON /CHEBY/DCHEB, CCHEB C X IF (I.LT.0) THEN X DZETA = 0.0D0 X ELSE IF (DCHEB.EQ.0.0D0) THEN X DZETA = 1.0D0 X ELSE X DZETA = DCHEB X END IF C X RETURN X END C C********************************************************* SHAR_EOF chmod 0600 dble/lal/dcoeff.f || echo 'restore of dble/lal/dcoeff.f failed' Wc_c="`wc -c < 'dble/lal/dcoeff.f'`" test 2725 -eq "$Wc_c" || echo 'dble/lal/dcoeff.f: original size 2725, current size' "$Wc_c" fi # ============= dble/lal/dlal.inc ============== if test -f 'dble/lal/dlal.inc' -a X"$1" != X"-c"; then echo 'x - skipping dble/lal/dlal.inc (File already exists)' else echo 'x - extracting dble/lal/dlal.inc (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/lal/dlal.inc' && C********************************************************************** C C Copyright (C) 1991 Roland W. Freund and Noel M. Nachtigal C All rights reserved. C C This code is part of a copyrighted package. For details, see the C file `cpyrit.doc' in the current directory. C C ***************************************************************** C ANY USE OF THIS CODE CONSTITUES ACCEPTANCE OF THE TERMS OF THE C COPYRIGHT NOTICE C ***************************************************************** C C********************************************************************** C C These are preprocessor definitions for the Lanczos algorithm. C #define _S_(I) SC(1,Q(I)) #define _T_(I) SC(2,Q(I)) #define _SC_(I) SC(1,Q(I)) #define ST(I) SC(3,Q(I)) #define TS(I) SC(4,Q(I)) #define CSI(I) SC(5,Q(I)) #define SIG(I) SC(6,Q(I)) C #define TMAX TOL(1) #define TMIN TOL(2) #define TNRM TOL(3) #define TSVD TOL(4) C #define _V_(I) VW(1,Q(I)) #define _W_(I) VW(1,M+Q(I)) #define TMPV VW(1,2*M+1) #define TMPW VW(1,2*M+2) C #define WTV(I,J) WK(I,J) #define WTVQR WK(1,M+1) #define VEC1(I) WK(I,2*M+1) #define VEC2(I) WK(I,2*M+2) #define VEC3 WK(1,2*M+3) #define QRAUX WK(1,2*M+4) #define OLDINV WK(1,2*M+5) #define H_N(I) WK(I,2*M+6) #define H_NP1 WK(1,2*M+7) #define HNSAV WK(1,2*M+8) #define HNP1SAV WK(1,2*M+9) #define HNTMP WK(1,2*M+10) #define HNP1TMP WK(1,2*M+11) # #define NO_ERROR 0 #define CSI_ZERO 1 #define SIG_ZERO 2 #define ALL_ZERO CSI_ZERO + SIG_ZERO #define NORM_UPD 4 #define NO_CLOSE 8 #define NO_CONVG 16 #define NO_INPUT 32 SHAR_EOF chmod 0600 dble/lal/dlal.inc || echo 'restore of dble/lal/dlal.inc failed' Wc_c="`wc -c < 'dble/lal/dlal.inc'`" test 1597 -eq "$Wc_c" || echo 'dble/lal/dlal.inc: original size 1597, current size' "$Wc_c" fi # ============= dble/lal/deig.F ============== if test -f 'dble/lal/deig.F' -a X"$1" != X"-c"; then echo 'x - skipping dble/lal/deig.F (File already exists)' else echo 'x - extracting dble/lal/deig.F (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/lal/deig.F' && C********************************************************************** C C Copyright (C) 1991 Roland W. Freund and Noel M. Nachtigal C All rights reserved. C C This code is part of a copyrighted package. For details, see the C file `cpyrit.doc' in the current directory. C C ***************************************************************** C ANY USE OF THIS CODE CONSTITUES ACCEPTANCE OF THE TERMS OF THE C COPYRIGHT NOTICE C ***************************************************************** C C********************************************************************** C C This file contains an example driver code for an eigenvalue C solver that uses the Lanczos routine. C C********************************************************************** C X PROGRAM DEIG C C This program uses the Lanczos algorithm with lookahead to compute C eigenvalues. This is just an example driver code. The following C routines are required from the user: C C SUBROUTINE GETMAT C This is the first routine called by this driver; it is used to C initialize all the matrix data. This routine must set the C global variable NROW to the dimension of the matrix. C SUBROUTINE AXB (X,B) C Computes B = A * X. C SUBROUTINE ATXB (X,B) C Computes B = A^T * X. C DOUBLE PRECISION FUNCTION DETA(N) C Computes one of the inner vector recursion coefficients -- see C the DLAL routine for details. C DOUBLE PRECISION FUNCTION DZETA(N) C Computes one of the inner vector recursion coefficients -- see C the DLAL routine for details. C C In addition, the code uses the EISPACK routines BALANC and DHQR C to compute the eigenvalues of H. C The driver will ask the user for various run-time parameters, and C will read the initial data from the following files: C C v.dat = the first Lanczos vector V_1 C w.dat = the first Lanczos vector W_1 C C Note that the file names are in lower case (for systems where the C case is significant, such as Unix). All these vectors are assumed C to be of length NROW, as set by GETMAT. The entries of the vector C appear in order, one per line. It is the responsibility of the C user to ensure that there is enough data in the files. C C NOTE: This code uses an input format that, while valid on the Sun C and Cray compilers, might not be accepted by other compilers. In C particular, the construct C WRITE (6,'(A30,$)') 'This is a test' C is used to prevent the output processor from moving to the next C line after writing the text. If this construct is not supported C by the compiler, remove the dollar sign ($). C Also, the user input in this code is not bullet-proof. It assumes C that the user will provide valid inputs, i.e., numbers where they C are expected, etc. Providing invalid input type will likely crash C the program. C C Noel M. Nachtigal C July 16, 1990 C C********************************************************************** C #include "dlal.inc" C C********************************************************************** C X INTRINSIC ABS C X INCLUDE 'dimblk.inc' C C Lanczos related variables and data parameters. C X INTEGER HDIM, M X PARAMETER (HDIM = 500,M = 5) X INTEGER INFO, NLEN, Q(HDIM) X DOUBLE PRECISION ANORM, SC(6,M) X DOUBLE PRECISION VW(NDIM,2*M+2), WK(M,3*M+8) C C Eigenvalue specific variables. C X DOUBLE PRECISION HLAN(HDIM,HDIM), WLANI(HDIM), WLANR(HDIM) X DOUBLE PRECISION HCHK(HDIM,HDIM), WCHKI(HDIM), WCHKR(HDIM) C C Local variables. C X CHARACTER*1 ANS X INTEGER I, NLIM C C Initialize the matrix and get its norm. C X 10 CALL GETMAT X NLEN = NROW X 20 WRITE (6,'(A31,$)') 'Enter estimated matrix norm : ' X READ (5,*) ANORM C C Get the maximum number of Lanczos steps. C X WRITE (6,'(A31,$)') 'Maximum number of steps NLIM : ' X READ (5,*) NLIM X IF (NLIM.GT.HDIM) THEN X NLIM = HDIM X WRITE (6,'(A33)') 'NLIM exceeds the dimensions of H;' X WRITE (6,'(A18,I10)') 'NLIM adjusted to: ',NLIM X END IF C C Initialize the array of indices. For fun, we do not set up the C indices in increasing order; rather, we set them up so that the C various arrays will be filled from the end down. C X DO 30 I = 1,NLIM X Q(NLIM-I+1) = MOD(I-1,M)+1 X 30 CONTINUE C C Read in the vector v. C X OPEN (10,FILE = 'v.dat') X DO 40 I = 1,NLEN X READ (10,*) VW(I,Q(1)) X 40 CONTINUE X CLOSE (10) C C Read in the vector w. C X OPEN (10,FILE = 'w.dat') X DO 50 I = 1,NLEN X READ (10,*) VW(I,M+Q(1)) X 50 CONTINUE X CLOSE (10) C C No preconditioner in eigenvalue problems. C X PRECON = 0 C C Open the output files. C X INFO = 1106 X OPEN (11,FILE = 'res.out') C C Call the eigenvalue solver. C X CALL EIGLAL (NDIM,NLEN,HDIM,NLIM,M,VW,SC,WK,Q,ANORM,INFO,HLAN) C C Check why we stopped. C X IF (INFO.LT.0) THEN X WRITE (6,'(A40,I5)') X $ 'Error encountered in the DSVDC routine: ', -INFO X ELSE IF (INFO.EQ.NO_ERROR) THEN X WRITE (6,'(A32)') 'The algorithm ran without error.' X ELSE IF (INFO.EQ.CSI_ZERO) THEN X WRITE (6,'(A39)') 'An A-invariant subspace has been found.' X ELSE IF (INFO.EQ.SIG_ZERO) THEN X WRITE (6,'(A41)') 'An A^T-invariant subspace has been found.' X ELSE IF (INFO.EQ.ALL_ZERO) THEN X WRITE (6,'(A41)') 'Both invariant subspaces have been found.' X ELSE IF (INFO.EQ.NO_CLOSE) THEN X WRITE (6,'(A34)') 'The last block could not be closed.' X ELSE IF (INFO.EQ.NO_INPUT) THEN X WRITE (6,'(A15)') 'Invalid inputs.' X ELSE X WRITE (6,'(A19,I5)') 'Unknown INFO code: ', INFO X END IF C C Close the output files. C X CLOSE (11) C C Get the good Lanczos eigenvalues. C X CALL LANEIG (HDIM,NLIM,HLAN,HCHK,WLANR,WLANI,WCHKR,WCHKI) C C Output the selected eigenvalues to eigs.out. C X OPEN (10,FILE = 'eigs.out') X DO 100 I = 1, NLIM X WRITE (10,'(E25.18,A3,E25.18,A1)') WLANR(I),' + ',WLANI(I),'i' X 100 CONTINUE X CLOSE (10) C C Do it again? C X WRITE (6,'(A22,$)') 'Play it again (Y/N) ? ' X READ (5,'(A1)') ANS X IF ((ANS.EQ.'Y').OR.(ANS.EQ.'y')) THEN X WRITE (6,'(A28,$)') 'Read another matrix (Y/N) ? ' X READ (5,'(A1)') ANS X IF ((ANS.EQ.'Y').OR.(ANS.EQ.'y')) GO TO 10 X GO TO 20 X END IF C C That's all, folks. C X STOP X END C C********************************************************************** C X SUBROUTINE LANEIG (HDIM,NLAN,HLAN,HCHK,WLANR,WLANI, X $ WCHKR,WCHKI) C C Purpose: C This subroutine extracts the genuine eigenvalues obtained by the C Lanczos algorithm using the Cullum-Willoughby approach. C C Parameters: C HDIM = the dimensioned size of the arrays HLAN and HCHK (input). C NLAN = on entry, the actual size of the Hessenberg matrix; on C exit, the number of eigenvalues extracted in WLANR and C WLANI (input). C HLAN = the Hessenberg matrix from the Lanczos algorithm (input). C HCHK = work array of size (HDIM,HDIM) (output). C WLANR = the real part of the eigenvalues (output). C WLANI = the imaginary part of the eigenvalues (output). C WCHKR = work array of length NLAN (output). C WCHKI = work array of length NLAN (output). C C External routines used: C subroutine balanc(nm,n,A,low,igh,scale) C Balances the matrix A. C subroutine dcopy(n,dx,incx,dy,incy) C Computes dy = dx. C double precision deps() C Returns machine epsilon. C subroutine dhqr(nm,n,low,igh,H,wr,wi,ierr) C Finds eigenvalues of the real upper Hessenberg matrix H. C subroutine hsort(n,x,y) C Sorts the array x. C C Noel M. Nachtigal C November 2, 1990 C X INTRINSIC ABS, SQRT X EXTERNAL DEPS X DOUBLE PRECISION DEPS C X INTEGER HDIM, NLAN X DOUBLE PRECISION HLAN(HDIM,HDIM), HCHK(HDIM,HDIM) X DOUBLE PRECISION WCHKR(*), WCHKI(*), WLANR(*), WLANI(*) C C Local variables. C X LOGICAL SAVED X INTEGER I, J, K, NCHK, NDEL X DOUBLE PRECISION DTMP1, DTMP2, LASTR, LASTZ , DTMP3, DTMP4 X DOUBLE PRECISION TOL, TOLR, TOLZ C C Extract the submatrix. C X NDEL = 1 X NCHK = NLAN - NDEL X DO 10 I = 1, NCHK X CALL DCOPY (NCHK,HLAN(NDEL+1,NDEL+I),1,HCHK(1,I),1) X 10 CONTINUE C C Balance the matrix H and compute its eigenvalues. C X WRITE (6,'(A37)') 'Computing eigenvalues of the matrix H' X CALL BALANC (HDIM,NLAN,HLAN,I,J,WLANR) X CALL DHQR (HDIM,NLAN,I,J,HLAN,WLANR,WLANI,K) C C Check the error code. C X IF (K.NE.0) THEN X WRITE (6,'(A24,I2)') 'Error return from DHQR: ', K X STOP X END IF C C Sort the eigenvalues. C X CALL HSORT (NLAN,WLANR(1),WLANI(1)) C C Check for small dimensions. C X IF (NCHK.LT.1) RETURN C C Balance the check matrix and compute its eigenvalues. C X WRITE (6,'(A37)') 'Computing eigenvalues of check matrix' X CALL BALANC (HDIM,NCHK,HCHK,I,J,WCHKR) X CALL DHQR (HDIM,NCHK,I,J,HCHK,WCHKR,WCHKI,K) C C Check the error code. C X IF (K.NE.0) THEN X WRITE (6,'(A24,I12)') 'Error return from DHQR: ', K X STOP X END IF C C Sort the eigenvalues. C X CALL HSORT (NCHK,WCHKR(1),WCHKI(1)) C C Initialize the separation tolerance. C X TOL = SQRT(DEPS()) C C Debugging output. C C OPEN (10,FILE='lan.out') C OPEN (11,FILE='chk.out') C DO 20 I = 1, NCHK C WRITE (10,'(E25.18,A3,E25.18,A1)') WLANR(I),' + ',WLANI(I),'i' C WRITE (11,'(E25.18,A3,E25.18,A1)') WCHKR(I),' + ',WCHKI(I),'i' C20 CONTINUE C DO 30 I = NCHK+1, NLAN C WRITE (10,'(E25.18,A3,E25.18,A1)') WLANR(I),' + ',WLANI(I),'i' C30 CONTINUE C CLOSE (10) C CLOSE (11) C C Eliminate repeated eigenvalues from the check eigenvalues. Also, C remove the second eigenvalue in complex eigenvalue pairs. C X K = 1 X LASTR = WCHKR(1) X LASTZ = SQRT(WCHKR(1)**2 + WCHKI(1)**2) X TOLR = TOL * ABS(LASTR) X TOLZ = TOL * LASTZ X DO 40 I = 2, NCHK X DTMP1 = WCHKR(I) X DTMP2 = SQRT(WCHKR(I)**2 + WCHKI(I)**2) X IF (ABS(DTMP1-LASTR).LE.TOLR) THEN X IF (ABS(DTMP2-LASTZ).LE.TOLZ) GO TO 40 X END IF X K = K + 1 X WCHKR(K) = WCHKR(I) X WCHKI(K) = ABS(WCHKI(I)) X LASTR = DTMP1 X LASTZ = DTMP2 X TOLR = TOL * ABS(LASTR) X TOLZ = TOL * LASTZ X 40 CONTINUE X NCHK = K C C Check the eigenvalues. We keep only eigenvalues which appear only C in the Lanczos matrix, and eigenvalues which appear several times C (even if they appear in both matrices). C The approach used is pretty brutal; it could be more sophisticated. C X K = 0 X LASTR = 0.0 X LASTZ = 0.0 X TOLR = 0.0 X TOLZ = 0.0 X SAVED = .FALSE. X DO 60 I = 1, NLAN X DTMP1 = WLANR(I) X DTMP2 = SQRT(WLANR(I)**2 + WLANI(I)**2) C C Does this have same real part and magnitude as the last one? C X IF (ABS(DTMP1-LASTR).LE.TOLR) THEN X IF (ABS(DTMP2-LASTZ).LE.TOLZ) THEN C C We have a second eigenvalue with same real part and magnitude. Do C we have it saved already? C X IF (.NOT.SAVED) THEN C C It has not been extracted. Is it from a pair of complex ew's? C X IF (WLANI(I).NE.0.0) THEN C C It is the second one in a pair of complex eigenvalues. Is it a C repeated pair? C X IF (I.GT.1) THEN X DTMP3 = ABS(WLANI(I)) X DTMP4 = ABS(DTMP3 - ABS(WLANI(I-2))) X IF (DTMP4.GT.(TOL*DTMP3)) GO TO 60 X END IF C C If we get here, it is a multiple complex pair that appears in the C two matrices. C X K = K + 1 X WLANR(K) = WLANR(I) X WLANI(K) = ABS(WLANI(I)) X K = K + 1 X WLANR(K) = WLANR(I) X WLANI(K) = -ABS(WLANI(I)) X ELSE C C If we get here, it is a multiple eigenvalue that appears in both C matrices. C X K = K + 1 X WLANR(K) = WLANR(I) X WLANI(K) = WLANI(I) X END IF X SAVED = .TRUE. X END IF X GO TO 60 X END IF X END IF C C If we get here, we have a new eigenvalue. Save it for next time. C X LASTR = DTMP1 X LASTZ = DTMP2 X TOLR = TOL * ABS(LASTR) X TOLZ = TOL * LASTZ X SAVED = .FALSE. C C Check it against the eigenvalues of the check matrix. C X DO 50 J = 1, NCHK X DTMP1 = ABS(LASTR - WCHKR(J)) X IF (DTMP1.LT.TOLR) THEN X DTMP2 = ABS(WLANI(I)) - WCHKI(J) X DTMP1 = SQRT(DTMP1**2 + DTMP2**2) X IF (DTMP1.LT.TOLZ) GO TO 60 X END IF X 50 CONTINUE C C It appears only in the Lanczos matrix, so it's good. C X SAVED = .TRUE. X DTMP1 = WLANR(I) X DTMP2 = ABS(WLANI(I)) X IF (DTMP2.LT.TOLZ) DTMP2 = 0.0 X K = K + 1 X WLANR(K) = DTMP1 X WLANI(K) = DTMP2 X IF (DTMP2.NE.0.0) THEN X K = K + 1 X WLANR(K) = DTMP1 X WLANI(K) = -DTMP2 X END IF X 60 CONTINUE X NLAN = K C X RETURN X END C C********************************************************************** SHAR_EOF chmod 0600 dble/lal/deig.F || echo 'restore of dble/lal/deig.F failed' Wc_c="`wc -c < 'dble/lal/deig.F'`" test 13813 -eq "$Wc_c" || echo 'dble/lal/deig.F: original size 13813, current size' "$Wc_c" fi # ============= dble/lal/deiglal.F ============== if test -f 'dble/lal/deiglal.F' -a X"$1" != X"-c"; then echo 'x - skipping dble/lal/deiglal.F (File already exists)' else echo 'x - extracting dble/lal/deiglal.F (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/lal/deiglal.F' && C********************************************************************** C C Copyright (C) 1991 Roland W. Freund and Noel M. Nachtigal C All rights reserved. C C This code is part of a copyrighted package. For details, see the C file `cpyrit.doc' in the current directory. C C ***************************************************************** C ANY USE OF THIS CODE CONSTITUES ACCEPTANCE OF THE TERMS OF THE C COPYRIGHT NOTICE C ***************************************************************** C C********************************************************************** C C This file contains the routines for an eigenvalue solver which C uses the Lanczos code. EIGLAL is the basic routine used to obtain C the Hessenberg matrix whose eigenvalues are taken as estimates C the eigenvalues of A. C C********************************************************************** C X SUBROUTINE EIGLAL (NDIM,NLEN,HDIM,NLIM,M,VW,SC,WK,Q,ANORM,INFO,H) C C Purpose: C This subroutine uses the Lanczos algorithm to set up a Hessenberg C matrix that can be used to compute eigenvalue estimates for A. It C runs the Lanczos algorithm for NLIM steps, storing the columns of C H returned by DLAL in H. The caller initializes the following: C VW(:,Q(1)) = the first Lanczos vector V_1 C VW(:,M+Q(1)) = the first Lanczos vector W_1 C Q = the array of wrapped indices C ANORM = estimate for the norm of the matrix (optional) C INFO = the output units, if any C C Parameters: C NDIM = the dimensioned size of the array VW. Must be NDIM >= 1; C checked for validity (input). C NLEN = the actual size of the Lanczos vectors V and W; this also C implicitly determines the size of the matrix A. Must be C 1 <= NLEN <= NDIM; checked for validity (input). C HDIM = the dimensioned size of H. Must be HDIM >= 1; checked C for validity (input). C NLIM = the maximum number of steps the algorithm can take before C H overflows. Must be 1 <= NLIM <= HDIM; checked for C validity. On exit, it is the size of the usable part of C H, i.e., the eigenvalues of H(1:NLIM,1:NLIM) can be used C as estimates for NLIM of the eigenvalues of A (input/ C output). C M = the maximum number of Lanczos vectors that can be stored C in the array VW. It is related to the size of the largest C block that can be built. The algorithm runs out of memory C when the number of vectors in two consecutive blocks C reaches M. Must be M >= 3; checked for validity (input). C VW = work array dimensioned (NDIM,2*M+2) words. It is used to C store the Lanczos vectors V in VW(:,1:M), the vectors W C in VW(:,M+1:2*M), and two temporary vectors used by DLAL C in VW(:,2*M+1) and VW(:,2*M+2). The Lanczos vectors V and C W are stored wrapped, i.e., V_N is stored in VW(:,Q(N)) C and W_N is stored in VW(:,M+Q(N)), where Q(N) is assumed C to be a wrapped index array -- see below (input/output). C SC = work array dimensioned (5,M), used to store the various C scale factors. We have: C SC(1,i) = S(i) / S(i-1) C SC(2,i) = T(i) / T(i-1) C SC(3,i) = S(i) / T(i) C SC(4,i) = CSI(i) C SC(5,i) = SIG(i) C Note that the scale routine DSCALE expects to receive the C scale factors in a 5x1 vector as the one described above. C This routine initializes the first column; thereafter, C the DLAL routine will update the array (input/output). C WK = work array dimensioned (M,5*M+14), used to store internal C variables. We have: C WK(:,1:M) = (W_{NK}^T V_{NK}) C WK(:,M+1) to WK(:,2*M) C = (W_{NK}^T V_{NK})^{-1} C WK(:,2*M+1) to WK(:,3*M) C = work array for the SVD routine DSVDC C WK(:,3*M+1) = temporary vector C WK(:,3*M+2) = temporary vector C WK(:,3*M+3) = temporary vector C WK(:,3*M+4) = the saved last column of the matrix C (W_{NKM1}^T V_{NKM1})^{-1} C WK(:,3*M+5) = H(NK:NKP1,N) C WK(:,3*M+6) = H(NK:NKP1,N+1) C WK(:,3*M+7) = the saved part of H(N), used in case C the block is restarted C WK(:,3*M+8) = the saved part of H(NP1), used in C case the block is restarted C (input/output). C Q = integer array specifying the indices for all the wrapped C variables (V,W,SC,WK). To allow the algorithm to run more C than M steps, the variables wrap around, in that Q(I) is C the index of the slots where the variables are stored at C the I-th step. Normally, these indices would be in order, C basically Q(I) = I MOD M + 1, but the algorithm makes no C assumptions to this effect. These indices are not checked C in any way for validity (input). C ANORM = user-supplied estimate for the norm of A. On exit, it is C set to the last value used by the algorithm. The value is C updated by the algorithm whenever it needs to close a C block (input/output). C INFO = information passing variable. C Upon entry, it gives the numbers of the output units used C to trace execution. There are two such units available, C one where the smallest singular values are sent, and the C other where various trace messages about the progress of C the algorithm are sent. If INFO is represented as xxyy, C then xx is the unit number for the singular values, and C yy is the unit number for the trace messages. For example C INFO = 1106 means that the singular values will be sent C to unit 11 and the trace messages to unit 6. INFO = 0 C disables both outputs. It is the responsibility of the C caller to ensure that the units are ready for output. C Upon exit: C INFO = 0 ==> nothing to report, algorithm converged C INFO < 0 ==> the SVD routine returned this error code C in DLAL (with positive sign) C INFO = 1 ==> an A-invariant subspace has been found C INFO = 2 ==> an A^T-invariant subspace has been found C INFO = 3 ==> both subspaces have been found C INFO = 4 ==> the norm estimate was updated C INFO = 8 ==> the last block could not be closed C INFO = 32 ==> invalid inputs C For more details, see the description in the routine DLAL C (input/output). C H = array dimensioned (HDIM,HDIM) used for H (output). C C External routines used: C subroutine axb(x,b) C Computes b = A * x. C subroutine atxb(x,b) C Computes b = A^T * x. C subroutine dcopy(n,dx,incx,dy,incy) C Computes dy = dx. C double precision ddot(n,dx,incx,dy,incy) C Computes the dot product of dx and dy. C double precision deps() C Returns machine epsilon. C subroutine dlal(ndim,nlen,m,n,nk,nkm1,vw,sc,wk,q,norms,tol,info) C Does one step of the look-ahead Lanczos algorithm. C subroutine dscal(n,da,dx,incx). C Computes dx = da * dx. C subroutine dscale(n,v,w,sc,tol) C Scales the Lanczos vectors v and w. C C Noel M. Nachtigal C October 25, 1990 C C********************************************************************** C #include "dlal.inc" C C********************************************************************** C X INTRINSIC MAX, SQRT C X EXTERNAL DDOT, DEPS X DOUBLE PRECISION DDOT, DEPS C X INTEGER HDIM, INFO, M, NLEN, NLIM, NDIM, Q(NLIM) X DOUBLE PRECISION ANORM, H(HDIM,HDIM), SC(6,M) X DOUBLE PRECISION VW(NDIM,2*M+2), WK(M,3*M+8) C C Local variables. C X INTEGER N, NK, NKM1, NSAV, ONKM1, TF, VF X DOUBLE PRECISION DTMP, NORMS(3), TOL(4) C C Extract the output units TF and VF from INFO. C X TF = INFO / 100 X INFO = INFO - TF * 100 X VF = INFO C C Check whether the inputs are valid. C X INFO = NO_ERROR X IF (NDIM.LT.1) INFO = NO_INPUT X IF (NLEN.LT.1) INFO = NO_INPUT X IF (NLEN.GT.NDIM) INFO = NO_INPUT X IF (HDIM.LT.1) INFO = NO_INPUT X IF (NLIM.LT.1) INFO = NO_INPUT X IF (NLIM.GT.HDIM) INFO = NO_INPUT X IF (M.LT.3) INFO = NO_INPUT X IF (INFO.NE.NO_ERROR) RETURN C C Set up the Lanczos tolerances. C X DTMP = DEPS() X TMIN = SQRT(DTMP) X TMAX = 1.0 / TMIN X TNRM = SQRT(TMIN) X TSVD = DTMP C C Initialize the counters. C X N = 1 X NK = 1 X NKM1 = 1 C C Scale the first pair of Lanczos vectors. C X CSI(1) = 1.0 X SIG(1) = 1.0 X ST(1) = 1.0 X CALL DSCALE (NLEN,_V_(1),_W_(1),_SC_(1),TOL) C C Check for invariant subspaces (already?). C X IF (CSI(1).EQ.-1.0) INFO = INFO + CSI_ZERO X IF (SIG(1).EQ.-1.0) INFO = INFO + SIG_ZERO X IF (INFO.NE.NO_ERROR) RETURN C C Set up WTV(1,1). C X WTV(1,1) = DDOT(NLEN,_V_(1),1,_W_(1),1) X WTV(1,1) = SIG(1) * CSI(1) * WTV(1,1) C C Initialize the norm estimate. C X NORMS(1) = ANORM X NORMS(2) = 0.0 C C Iterate. C X 10 ONKM1 = NKM1 C C If we have closed a block, save the working variables, in case we C need to restart. Also, reset the norm estimator. C X IF (N.EQ.NK) THEN X CALL DCOPY (N-NKM1+1,H_NP1,1,HNP1SAV,1) X CALL DCOPY (N-ONKM1+1,H_N(1),1,HNSAV,1) X NORMS(2) = 0.0 X NSAV = N X END IF C C Check whether we have enough room left in the arrays. C X 20 INFO = NO_ERROR X IF (N-NKM1+2.GE.M) INFO = 1 X IF ((INFO.NE.NO_ERROR).AND.(VF.NE.0)) THEN X WRITE (VF,'(A39)') 'Block is maximal, recommending closure.' X END IF C C Compute the matrix vector products. C X CALL AXB (_V_(N), _V_(N+1)) X CALL ATXB (_W_(N), _W_(N+1)) C C Save the block info. C X CALL DCOPY (N-NKM1+1,H_NP1,1,HNP1TMP,1) X CALL DCOPY (N-ONKM1+1,H_N(1),1,HNTMP,1) C C Do one step of the Lanczos algorithm. C X CALL DLAL (NDIM,NLEN,M,N,NK,NKM1,VW,SC,WK,Q,NORMS,TOL,VF,INFO) C C Set ANORM to the current value of the norm estimate. C X ANORM = NORMS(1) C C Check the info passing variable. C We check whether the DSVDC routine reported errors or whether the C block did not close when it was maximal, both of which result in C an immediate return, and whether an invariant subspace was found, C which just stops the iteration. C X IF (INFO.LT.0) THEN X NLIM = N X RETURN X ELSE IF (INFO.EQ.CSI_ZERO) THEN X NLIM = N X ELSE IF (INFO.EQ.SIG_ZERO) THEN X NLIM = N X ELSE IF (INFO.EQ.ALL_ZERO) THEN X NLIM = N X ELSE IF (INFO.EQ.NORM_UPD) THEN X NSAV = N-1 X INFO = NO_ERROR X CALL DCOPY (N-NKM1,HNP1TMP,1,HNP1SAV,1) X CALL DCOPY (N-ONKM1,HNTMP,1,HNSAV,1) X IF (VF.NE.0) WRITE (VF,'(A20)') 'Norm updated.' X ELSE IF (INFO.EQ.NO_CLOSE) THEN X N = NK X IF (VF.NE.0) WRITE (VF,'(A20)') 'Block did not close:' C C Block did not close, do we have another norm estimate? C X IF (NORMS(2).EQ.0.0) THEN X IF (VF.NE.0) WRITE (VF,'(A47)') X $ '==> no new norm estimates available (aborting).' X NLIM = N X RETURN X ELSE C C Update the norm --- the block is guaranteed to close now. We then C restart the block. C X NORMS(1) = NORMS(2) X IF (VF.NE.0) WRITE (VF,'(A30, E16.8)') X $ '==> updating norm estimate to ', NORMS(1) X N = NSAV X NORMS(2) = 0.0D0 X CALL DCOPY (N-NKM1+1,HNP1SAV,1,H_NP1,1) X CALL DCOPY (N-ONKM1+1,HNSAV,1,H_N(1),1) X GO TO 20 X END IF X END IF C C Output the singular values. C X IF (TF.NE.0) WRITE (TF,'(E16.8)') NORMS(3) C C Initialize the "next" column of H. First, zero it all out, then, C copy the part we have so far. C X CALL DSCAL (NLIM,0.0D0,H(1,N-1),1) X CALL DCOPY (N-ONKM1+1,H_N(1),1,H(ONKM1,N-1),1) C C Set up the work vector for the next step. C X CALL DCOPY (N-NKM1+1,H_NP1,1,H_N(1),1) C C Iterate up to NLIM steps. C X IF (N.LT.NLIM) GO TO 10 C C Adjust the dimension NLIM, which right now is one bigger than the C size of the biggest usable submatrix of H. C X NLIM = NLIM - 1 C X RETURN X END C C********************************************************************** SHAR_EOF chmod 0600 dble/lal/deiglal.F || echo 'restore of dble/lal/deiglal.F failed' Wc_c="`wc -c < 'dble/lal/deiglal.F'`" test 13177 -eq "$Wc_c" || echo 'dble/lal/deiglal.F: original size 13177, current size' "$Wc_c" fi # ============= dble/lal/dlal.F ============== if test -f 'dble/lal/dlal.F' -a X"$1" != X"-c"; then echo 'x - skipping dble/lal/dlal.F (File already exists)' else echo 'x - extracting dble/lal/dlal.F (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/lal/dlal.F' && C********************************************************************** C C Copyright (C) 1991 Roland W. Freund and Noel M. Nachtigal C All rights reserved. C C This code is part of a copyrighted package. For details, see the C file `cpyrit.doc' in the current directory. C C ***************************************************************** C ANY USE OF THIS CODE CONSTITUES ACCEPTANCE OF THE TERMS OF THE C COPYRIGHT NOTICE C ***************************************************************** C C********************************************************************** C C This file contains the basic routines for the look-ahead Lanczos C algorithm. DLAL carries out one step of the algorithm and DSCALE C is used to scale the Lanczos vectors. C C********************************************************************** C X SUBROUTINE DLAL (NDIM,NLEN,M,N,NK,NKM1,VW,SC,WK,Q,NORMS,TOL,VF, X $ INFO) C C Purpose: C This subroutine carries out one step of the look-ahead Lanczos C algorithm. Most of the inputs to this routine are not checked for C validity. This is a low-level routine, meant to be called often; C as such, it is the resposibility of the caller to ensure that the C various inputs are valid. Normally, this routine is not called C directly from the top-most level, but rather from an intermediate C routine that uses Lanczos to solve either eigenvalue problems or C linear systems. At step 1, the calling routine initializes the C following: C VW(:,Q(1)) = the Lanczos vector V_1 C VW(:,M+Q(1)) = the Lanczos vector W_1 C SC(:,Q(1)) = the scaling factors for V_1 and W_1 C WK(1,1) = the dot product W_1^T V_1 C Q = the array of wrapped indices C NORMS(1) = the initial estimate for the norm of A C TOL(1:4) = tolerances C VF = output unit for trace messages C At each subsequent step, the calling routine must initialize: C VW(:,Q(N+1)) = the matrix-vector product A * V_N C VW(:,M+Q(N+1)) = the matrix-vector product A^T * W_N C Otherwise, it is usually left up to this routine to update the C other variables used. Upon exit, N, NK, NKM1, VW, SC, WK, NORMS, C TOL, and INFO are normally updated by this routine to the values C for the next step. C C Parameters: C NDIM = the dimensioned size of the array VW (input). C NLEN = the actual size of the Lanczos vectors V and W; this also C implicitly determines the size of the matrix A (input). C M = the maximum number of Lanczos vectors that can be stored C in the array VW. It is related to the size of the largest C block that can be built. The algorithm runs out of memory C when the number of vectors in two consecutive blocks C reaches M. Must be at least 3 (input). C N = the index of the last pair of vectors (input/output). C NK = the index of the last regular vectors (input/output). C NKM1 = the index of the next-to-the-last regular vectors (input/ C output). C VW = work array dimensioned (NDIM,2*M+2) words. It is used to C store the Lanczos vectors V in VW(:,1:M), the vectors W C in VW(:,M+1:2*M), and two temporary vectors used by DLAL C in VW(:,2*M+1) and VW(:,2*M+2). The Lanczos vectors V and C W are stored wrapped, i.e., V_N is stored in VW(:,Q(N)), C and W_N is stored in VW(:,M+Q(N)), where Q(N) is assumed C to be a wrapped index array -- see below (input/output). C SC = work array dimensioned (6,M) words, used for the various C scale factors. We have: C SC(1,i) = S(i) / S(i-1) C SC(2,i) = T(i) / T(i-1) C SC(3,i) = S(i) / T(i) C SC(4,i) = T(i) / S(i) C SC(5,i) = CSI(i) C SC(6,i) = SIG(i) C Note that the scale routine DSCALE expects to receive the C scale factors in a 6x1 vector as the one described above C (input/output). C WK = work array dimensioned (M,2*M+7) words, used for internal C variables. We have: C WK(:,1:M) = (W_{NK}^T V_{NK}) C WK(:,M+1) to WK(:,2*M) C = work array for the QR and SVD routines C WK(:,2*M+1) = temporary vector C WK(:,2*M+2) = temporary vector C WK(:,2*M+3) = temporary vector C WK(:,2*M+4) = temporary vector C WK(:,2*M+5) = last column of the inverse C (W_{NK}^T V_{NK})^{-1} C WK(:,2*M+6) = H(NK:NKP1,N) C WK(:,2*M+7) = H(NK:NKP1,N+1) C Of particular interest to the caller are H(NK:NKP1,N) and C H(NK:NKP1,N+1), since they are parts of the columns of H. C Usually, the caller will extract these after each call C and either store them so as to form H (for eigenvalues) C or use them to update X_N (for linear systems). Note that C the code assumes that the inner recursion coefficients C are the same for V and for W, in the monic formulation of C the algorithm (input/output). C Q = integer array specifying the indices for all the wrapped C variables (V,W,SC,WK). To allow the algorithm to run more C than M steps, the variables wrap around, in that Q(I) is C the index of the slots where the variables are stored at C the I-th step. Normally, these indices would be in order, C basically Q(I) = I MOD M + 1, but the algorithm makes no C assumptions to this effect. These indices are not checked C in any way for validity (input). C NORMS = vector with estimates for the norm of A. NORMS(1) is the C current estimate, or 0.0 if not estimates are available. C In this case, the routine will compute a lower bound for C the norm. NORMS(2) is usually used in conjunction with C restarting a block if the algorithm runs out of memory. C NORMS(3) is the smallest singular value from the current C iteration (input/output). C TOL = vector with the tolerances used in the various checks. We C have: C TOL(1) = upper bound for the range of CSI and SIG C TOL(2) = lower bound for the range of CSI and SIG C TOL(3) = convergence tolerance for the norms of the C Lanczos vectors C TOL(4) = level below which the singular values of the C moment matrix are numerically zero C Note that the scale routine DSCALE expects to receive the C first three tolerances in a 3x1 vector as described. The C values are not checked (input). C VF = output unit for a trace file. If VF non-zero, the routine C will output to unit VF trace messages detailing execution C decisions. The output unit is assumed to be available and C ready (input). C INFO = information passing variable. C On input: C INFO = 0 ==> proceed normally C INFO = 1 ==> closing the block strongly recommended; C if the block doesn't close naturally, do C not update the counters, but update the C norm estimate, if possible. C Upon exit: C INFO = 0 ==> nothing to report C INFO < 0 ==> the SVD routine returned this error code C (but with positive sign) C INFO = 1 ==> an A-invariant subspace has been found C INFO = 2 ==> an A^T-invariant subspace has been found C INFO = 3 ==> both subspaces have been found C INFO = 4 ==> the norm estimate was updated C INFO = 8 ==> the block did not close, though strongly C recommended (INFO=1 on input); updated C norm estimate, but did not compute any C vectors and did not update the counters. C (input/output). C C External routines used: C subroutine daxpy(n,da,dx,incx,dy,incy) C Computes dy = da * dx + dy. C subroutine dcopy(n,dx,incx,dy,incy) C Computes dy = dx. C double precision ddot(n,dx,incx,dy,incy) C Computes dy' * dx. C double precision deta(i) C Computes the second recursion scalar for the inner vectors. C double precision dnrm2(n,dx,incx) C Computes the 2-norm of dx. C subroutine dqrdc(x,ldx,n,p,qraux,jpvt,work,job) C Computes the QR decomposition of x. C subroutine dqrsl(x,ldx,n,k,qraux,y,qy,qty,b,rsd,xb,job,info) C Applies the QR decomposition of a matrix. C subroutine dscal(n,da,dx,incx) C Computes dx = da * dx. C subroutine dscale(nact,v,w,sc,tol) C Computes the scaling factors for v and w. C subroutine dsvdc(x,ldx,n,p,s,e,u,ldu,v,ldv,work,job,info) C Computes the singular value decomposition of x. C double precision dzeta(i) C Computes the first recursion scalar for the inner vectors. C C Noel M. Nachtigal C August 28, 1990 C C********************************************************************** C #include "dlal.inc" C C********************************************************************** C X INTRINSIC ABS, MAX X EXTERNAL DDOT, DETA, DNRM2, DZETA X DOUBLE PRECISION DDOT, DETA, DNRM2, DZETA C X INTEGER INFO, M, N, NDIM, NK, NKM1, NLEN, Q(*), VF X DOUBLE PRECISION NORMS(3), SC(6,M), TOL(4) X DOUBLE PRECISION VW(NDIM,2*M+2), WK(M,2*M+7) C C Local variables. C X INTEGER BLKSIZ, HBASE, I, LINFO, NP1 X DOUBLE PRECISION ANORM, INVSCW, INVSCV, TETA, TZETA X DOUBLE PRECISION DTMP1, DTMP2, DTMP3, NUNORM, NUNRM1, NUNRM2 X DOUBLE PRECISION WNV, WNP1V X LOGICAL INNER, TEST1, TEST2 C C Compute local counters. C X NP1 = N + 1 X HBASE = 1 - NKM1 X BLKSIZ = N - NK + 1 C C Initialize the norm estimate. C X IF (N.LE.5) THEN X DTMP1 = SIG(N) * DNRM2(NLEN,_V_(NP1),1) X DTMP2 = CSI(N) * DNRM2(NLEN,_W_(NP1),1) X NORMS(1) = MAX(DTMP1,DTMP2,NORMS(1)) X END IF X IF (NORMS(2).LT.0.0D0) NORMS(2) = 0.0D0 X ANORM = NORMS(1) X NUNORM = NORMS(2) X NUNRM1 = 0.0D0 X NUNRM2 = 0.0D0 C C Zero out the work portion of the column of H. C X CALL DSCAL (BLKSIZ,0.0D0,H_N(HBASE+NK),1) C C Subtract the part common to both types of vectors. C X INVSCV = 1.0D0 / SIG(N) X INVSCW = 1.0D0 / CSI(N) X DO 10 I = NKM1, NK-1 X DTMP1 = INVSCV * SIG(I) * H_N(HBASE+I) X CALL DAXPY (NLEN,-DTMP1,_V_(I),1,_V_(NP1),1) X DTMP1 = INVSCW * CSI(I) * H_N(HBASE+I) * ST(N) X $ * TS(I) X CALL DAXPY (NLEN,-DTMP1,_W_(I),1,_W_(NP1),1) X 10 CONTINUE C C Compute the singular values of (W_{NK}^T V_{NK}). If it is a 2x2 C or bigger, we need to use the SVD, and therefore copy the matrix, C since the SVD routine destroys its argument. C X IF (BLKSIZ.EQ.1) THEN X DTMP1 = ABS(WTV(1,1)) X ELSE X CALL DCOPY (M*BLKSIZ,WTV(1,1),1,WTVQR,1) X CALL DSVDC (WTVQR,M,BLKSIZ,BLKSIZ,VEC1(1), X $ VEC2(1),DTMP1,0,DTMP1,0,QRAUX,0,LINFO) X LINFO = -LINFO X IF (LINFO.NE.0) GO TO 80 X DTMP1 = VEC1(BLKSIZ) X END IF X LINFO = NO_ERROR C C Check the smallest singular value to determine if the matrix is C singular. C X NORMS(3) = DTMP1 X INNER = DTMP1.LT.TSVD X IF (INNER) THEN X IF (VF.NE.0) THEN X WRITE (VF,'(A7,I5,A21)') X $ 'Vector ',NP1,' is an inner vector; ' X WRITE (VF,'(A31,E12.3)') X $ '==> moment matrix is singular: ',DTMP1 X END IF X GO TO 60 X END IF C C Compute the QR decomposition of (W_{NK}^T V_{NK}). We first copy C it to an auxiliary array, since the DQRDC routine will overwrite C its parameter with the QR decomposition. C X CALL DCOPY (M*M,WTV(1,1),1,WTVQR,1) X CALL DQRDC (WTVQR,M,BLKSIZ,BLKSIZ,QRAUX,0,0.0D0,0) C C Compute the inner product (W_N^T A V_N). C X WNV = SIG(N) * CSI(N) X $ * DDOT(NLEN,_W_(N),1,_V_(NP1),1) C C Compute the (W_{NK}^T A V_N) term. C Note: this assumes that DETA(0) = 0.0. C X DO 20 I = 1, BLKSIZ-1 X VEC1(I) = DZETA(I-1) * WTV(I,BLKSIZ) X $ + _T_(NK+I) * WTV(I+1,BLKSIZ) X $ + DETA(I-1) * WTV(I-1,BLKSIZ) / _T_(NK+I-1) X 20 CONTINUE X VEC1(BLKSIZ) = WNV C C Compute H(NK:N,N) = (W_{NK}^T V_{NK})^{-1} W_{NK}^T A V_N. C X CALL DQRSL (WTVQR,M,BLKSIZ,BLKSIZ,QRAUX,VEC1(1), X $ DTMP1,VEC1(1),VEC1(1),VEC3,DTMP1,00110,I) C C Check whether we can build a regular vector with it. C X DTMP2 = 0.0D0 X DTMP3 = 0.0D0 X DO 30 I = 1, BLKSIZ X DTMP1 = ABS(VEC1(I)) X DTMP2 = DTMP2 + DTMP1 X DTMP3 = DTMP3 + DTMP1 * TS(NK+I-1) X 30 CONTINUE X DTMP3 = ST(N) * DTMP3 X TEST1 = (DTMP2.GT.ANORM).OR.(DTMP3.GT.ANORM) X IF (TEST1) THEN C C One or both of the norm checks has failed, we will have to build C an inner vector. Output trace messages and update norm estimate. C X IF (VF.NE.0) THEN X WRITE (6,'(A7,I5,A21)') X $ 'Vector ',NP1,' is an inner vector;' X IF (DTMP2.GT.ANORM) WRITE (6,'(A29,E10.3)') X $ '==> second term in V is bad: ',DTMP2/ANORM X IF (DTMP3.GT.ANORM) WRITE (6,'(A29,E10.3)') X $ '==> second term in W is bad: ',DTMP3/ANORM X END IF X NUNRM1 = MAX(DTMP2,DTMP3) X END IF C C We now build a regular vector. Save the temporary vectors in case C We now build a regular vector, regardless of the state of the flag C INNER. We do this so that the norm estimate gets a chance to be C updated by the second check. Save the temporary vectors in case C we need to restore them. C X CALL DCOPY (NLEN,_V_(NP1),1,TMPV,1) X CALL DCOPY (NLEN,_W_(NP1),1,TMPW,1) C C Add in the term V_{NK} H(NK:N,N). C X DO 40 I = NK, N X DTMP1 = INVSCV * SIG(I) * VEC1(I-NK+1) X CALL DAXPY (NLEN,-DTMP1,_V_(I),1,_V_(NP1),1) X DTMP1 = INVSCW * CSI(I) * VEC1(I-NK+1) * ST(N) X $ * TS(I) X CALL DAXPY (NLEN,-DTMP1,_W_(I),1,_W_(NP1),1) X 40 CONTINUE C C Scale the new vectors. C X ST(NP1) = ST(N) X CSI(NP1) = CSI(N) X SIG(NP1) = SIG(N) X CALL DSCALE (NLEN,_V_(NP1),_W_(NP1),SC(1,Q(NP1)),TOL) X H_N(HBASE+NP1) = _S_(NP1) C C Compute the inner product (W_{N+1}^T V_{N+1}). C X WNP1V = SIG(NP1) * CSI(NP1) X $ * DDOT(NLEN,_W_(NP1),1,_V_(NP1),1) C C Compute the last column of (W_{NK}^T V_{NK})^{-1}. C X VEC2(BLKSIZ) = 1.0D0 X CALL DSCAL (BLKSIZ-1,0.0D0,VEC2(1),1) X CALL DQRSL (WTVQR,M,BLKSIZ,BLKSIZ,QRAUX,VEC2(1), X $ DTMP1,VEC2(1),VEC2(1),VEC3,DTMP1,00110,I) C C Compute the term W_{NK}^T A V_{N+1} and check whether we will be C able to build either vector at the next step. The term sought is C the last column of (W_{NK}^T V_{NK})^{-1}, scaled appropriately, C though we do not actually scale it yet (it may be needed later). C X DTMP2 = 0.0D0 X DTMP3 = 0.0D0 X DO 50 I = 1, BLKSIZ X DTMP1 = ABS(VEC2(I)) X DTMP2 = DTMP2 + DTMP1 X DTMP3 = DTMP3 + DTMP1 * TS(NK+I-1) X 50 CONTINUE X DTMP1 = ABS(_T_(NP1) * WNP1V) X DTMP2 = DTMP1 * DTMP2 X DTMP3 = ST(N) * DTMP1 * DTMP3 X TEST2 = (DTMP2.GT.ANORM).OR.(DTMP3.GT.ANORM) C C The next vector would be bad, we have to build an inner vector. C Output trace messages and update norm estimate. C X IF (TEST2) THEN X IF (VF.NE.0) THEN X IF (.NOT.TEST1) WRITE (6,'(A7,I5,A21)') X $ 'Vector ',NP1,' is an inner vector;' X IF (DTMP2.GT.ANORM) WRITE (6,'(A30,E10.3)') X $ '==> next vector V will be bad:',DTMP2/ANORM X IF (DTMP3.GT.ANORM) WRITE (6,'(A30,E10.3)') X $ '==> next vector W will be bad:',DTMP3/ANORM X END IF X NUNRM2 = MAX(DTMP2,DTMP3) X END IF C C If either check failed, restore the temporary vectors and update C the norm estimate. C X INNER = TEST1.OR.TEST2 X IF (INNER) THEN X CALL DCOPY (NLEN,TMPV,1,_V_(NP1),1) X CALL DCOPY (NLEN,TMPW,1,_W_(NP1),1) X DTMP1 = MAX(NUNRM1,NUNRM2) X IF ((NUNORM.EQ.0.0D0).OR.(NUNORM.GT.DTMP1)) THEN X LINFO = NORM_UPD X NUNORM = DTMP1 X END IF X END IF C X 60 IF (INNER) THEN C C Check whether we were supposed to close the block. If so, return C without computing anything else. C X IF (INFO.NE.0) THEN X LINFO = NO_CLOSE X GO TO 80 X END IF C C We are building an inner vector. Add the terms from the inner C vector recursion. C Note: this assumes that DETA(0) = 0.0. C X TZETA = DZETA(N-NK) X H_N(HBASE+N) = TZETA X IF (TZETA.NE.0.0D0) THEN X CALL DAXPY (NLEN,-TZETA,_V_(N),1,_V_(NP1),1) X CALL DAXPY (NLEN,-TZETA,_W_(N),1,_W_(NP1),1) X END IF X TETA = DETA(N-NK) X IF (TETA.NE.0.0D0) THEN X DTMP1 = TETA * INVSCV * SIG(N-1) / _S_(N) X CALL DAXPY (NLEN,-DTMP1,_V_(N-1),1,_V_(NP1),1) X DTMP1 = TETA * INVSCW * CSI(N-1) / _T_(N) X CALL DAXPY (NLEN,-DTMP1,_W_(N-1),1,_W_(NP1),1) X H_N(HBASE+N-1) = TETA / _S_(N) X END IF C C Scale the new vectors. C X ST(NP1) = ST(N) X SIG(NP1) = SIG(N) X CSI(NP1) = CSI(N) X CALL DSCALE (NLEN,_V_(NP1),_W_(NP1),SC(1,Q(NP1)), X $ TOL) X H_N(HBASE+NP1) = _S_(NP1) C C Compute the inner product (W_{N+1}^T V_{N+1}). C X WNP1V = SIG(NP1) * CSI(NP1) X $ * DDOT(NLEN,_W_(NP1),1,_V_(NP1),1) C C Update the matrix (W_{NK}^T V_{NK}). C Note: this assumes that DETA(0) = 0.0. C X WTV(BLKSIZ+1,BLKSIZ+1) = WNP1V X DTMP1 = WNV X $ - TZETA * WTV(BLKSIZ,BLKSIZ) X $ - TETA * WTV(BLKSIZ,BLKSIZ-1) / _S_(N) X WTV(BLKSIZ,BLKSIZ+1) = DTMP1 / _S_(NP1) X WTV(BLKSIZ+1,BLKSIZ) = DTMP1 / _T_(NP1) X DTMP1 = ST(NP1) * TS(N) X DO 70 I = BLKSIZ-1, 1, -1 X DTMP2 = DETA(I) * WTV(I-1,BLKSIZ) / _T_(NK+I-1) X $ + (DZETA(I) - TZETA) * WTV(I,BLKSIZ) X $ - TETA * WTV(I,BLKSIZ-1) / _S_(N) X $ + _T_(NK+I) * WTV(I+1,BLKSIZ) X DTMP2 = DTMP2 / _S_(NP1) X DTMP1 = DTMP1 * ST(NK+I) * TS(NK+I-1) X WTV(BLKSIZ+1,I) = DTMP2 * DTMP1 X WTV(I,BLKSIZ+1) = DTMP2 X 70 CONTINUE C C Initialize H(NKM1:NK-1,N+1) for the next step. It is the last C column of (W_{NKM1}^T V_{NKM1})^{-1}, scaled appropriately. C X DTMP1 = _T_(NK) * WTV(1,BLKSIZ+1) X CALL DCOPY (NK-NKM1,OLDINV,1,H_NP1,1) X CALL DSCAL (NK-NKM1,DTMP1,H_NP1,1) C X ELSE C C We have built a regular vector. Output trace message. C X IF (VF.NE.0) WRITE (6,'(A7,I5,A21)') X $ 'Vector ',NP1,' is a regular vector.' C C Save H(NK:NKP1-1,N). C X CALL DCOPY (BLKSIZ,VEC1(1),1,H_N(HBASE+NK),1) C C Save the last column of (W_{NK}^T V_{NK})^{-1} for next step. C X CALL DCOPY (BLKSIZ,VEC2(1),1,OLDINV,1) C C Initialize H(NK:NKP1-1,N+1) for next step. It is the last column C of (W_{NK}^T V_{NK})^{-1}, scaled appropriately. C X DTMP1 = _T_(NP1) * WNP1V X CALL DSCAL (BLKSIZ,DTMP1,VEC2(1),1) X CALL DCOPY (BLKSIZ,VEC2(1),1,H_NP1,1) C C Initialize (W_{NK}^T V_{NK}) for next step. C X WTV(1,1) = WNP1V C C Update the counters. C X NKM1 = NK X NK = N + 1 X END IF C C Update the running counter. C X N = N + 1 C C Check for termination. C X IF ((CSI(NP1).EQ.-1.0D0).OR.(SIG(NP1).EQ.-1.0D0)) THEN X LINFO = NO_ERROR X IF (CSI(NP1).EQ.-1.0D0) LINFO = LINFO + CSI_ZERO X IF (SIG(NP1).EQ.-1.0D0) LINFO = LINFO + SIG_ZERO X END IF C C Save the updated norm estimate and set the INFO variable. C X 80 NORMS(2) = NUNORM X INFO = LINFO C X RETURN X END C C********************************************************************** C X SUBROUTINE DSCALE (N,V,W,SC,TOL) C C Purpose: C Does scaling in the Lanczos algorithm. Scales the vectors V and W C to unit length. Also checks for invariant subspaces. Note that it C does not check its inputs for validity. C C Parameters: C N = the length of the vectors (input). C V = the Lanczos vector V, scaled on output (input/output). C W = the Lanczos vector W, scaled on output (input/output). C SC(1) = S_{N+1} / S_N (output). C SC(2) = T_{N+1} / T_N (output). C SC(3) = on input, S_N / T_N; on exit, S_{N+1} / T_{N+1} (input/ C output). C SC(4) = on input, T_N / S_N; on exit, T_{N+1} / S_{N+1} (input/ C output). C SC(5) = on input, CSI_N; on exit, CSI_{N+1}. If it is -1.0, then C the norm of W was less than TOL(3) on input, indicating C an invariant subspace for A^T (input/output). C SC(6) = on input, SIGMA_N; on exit, SIGMA_{N+1}. If it is -1.0, C then the norm of V was less than TOL(3) on input, C indicating an invariant subspace for A (input/output). C TOL(1) = the level above which vectors will be scaled (input). C TOL(2) = the level below which vectors will be scaled (input). C TOL(3) = the tolerance level below which the norms of the vectors C are treated as zero (input). C C External routines used: C double precision dnrm2(n,dx,incx) C Returns the 2-norm of dx. C subroutine dscal(n,da,dx,incx) C Computes dx = da * dx. C C Noel M. Nachtigal C August 28, 1990 C X EXTERNAL DNRM2 X DOUBLE PRECISION DNRM2 C X INTEGER N X DOUBLE PRECISION SC(6), TOL(3), V(*), W(*) C C Local variables. C X DOUBLE PRECISION TMPS, TMPT C C Initialize the scale factors. C X SC(1) = DNRM2(N,V,1) X SC(2) = DNRM2(N,W,1) X IF (SC(1)*SC(6).LT.TNRM) SC(6) = -1.0D0 X IF (SC(2)*SC(5).LT.TNRM) SC(5) = -1.0D0 X IF ((SC(5).LT.0.0D0).OR.(SC(6).LT.0.0D0)) RETURN C C Compute the scale factors and scale the vectors. C X TMPS = 1.0D0 / SC(1) X TMPT = 1.0D0 / SC(2) C X IF ((TMPS.LT.TMIN).OR.(TMPS.GT.TMAX)) THEN X CALL DSCAL (N,TMPS,V,1) X TMPS = 1.0D0 X END IF X IF ((TMPT.LT.TMIN).OR.(TMPT.GT.TMAX)) THEN X CALL DSCAL (N,TMPT,W,1) X TMPT = 1.0D0 X END IF C X SC(4) = SC(2) * SC(5) / ( SC(1) * SC(6) * SC(3) ) X SC(3) = SC(1) * SC(6) * SC(3) / ( SC(2) * SC(5) ) X SC(1) = SC(1) * SC(6) X SC(2) = SC(2) * SC(5) X SC(5) = TMPT X SC(6) = TMPS C X RETURN X END C C********************************************************************** SHAR_EOF chmod 0600 dble/lal/dlal.F || echo 'restore of dble/lal/dlal.F failed' Wc_c="`wc -c < 'dble/lal/dlal.F'`" test 23494 -eq "$Wc_c" || echo 'dble/lal/dlal.F: original size 23494, current size' "$Wc_c" fi # ============= dble/lal/getomg.f ============== if test -f 'dble/lal/getomg.f' -a X"$1" != X"-c"; then echo 'x - skipping dble/lal/getomg.f (File already exists)' else echo 'x - extracting dble/lal/getomg.f (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/lal/getomg.f' && C********************************************************************** C C Copyright (C) 1991 Roland W. Freund and Noel M. Nachtigal C All rights reserved. C C This code is part of a copyrighted package. For details, see the C file `cpyrit.doc' in the current directory. C C ***************************************************************** C ANY USE OF THIS CODE CONSTITUES ACCEPTANCE OF THE TERMS OF THE C COPYRIGHT NOTICE C ***************************************************************** C C********************************************************************** C This file contains the scaling function GETOMG, which computes C the scaling factors Omega used in scaling the Hessenberg matrix C from the least squares problem solved by QMR. C C********************************************************************** C X DOUBLE PRECISION FUNCTION GETOMG (I) C C Purpose: C Returns the scaling parameter OMEGA(i). C C Parameters: C I = the index of the parameter OMEGA (input). C C Noel M. Nachtigal C October 7, 1990 C X INTEGER I C X GETOMG = 1.0D0 C X RETURN X END C C********************************************************************** SHAR_EOF chmod 0600 dble/lal/getomg.f || echo 'restore of dble/lal/getomg.f failed' Wc_c="`wc -c < 'dble/lal/getomg.f'`" test 1266 -eq "$Wc_c" || echo 'dble/lal/getomg.f: original size 1266, current size' "$Wc_c" fi # ============= dble/lal/dsys.F ============== if test -f 'dble/lal/dsys.F' -a X"$1" != X"-c"; then echo 'x - skipping dble/lal/dsys.F (File already exists)' else echo 'x - extracting dble/lal/dsys.F (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/lal/dsys.F' && C********************************************************************** C C Copyright (C) 1991 Roland W. Freund and Noel M. Nachtigal C All rights reserved. C C This code is part of a copyrighted package. For details, see the C file `cpyrit.doc' in the current directory. C C ***************************************************************** C ANY USE OF THIS CODE CONSTITUES ACCEPTANCE OF THE TERMS OF THE C COPYRIGHT NOTICE C ***************************************************************** C C********************************************************************** C C This file contains an example driver code for the QMR algorithm. C The code can be combined with preconditioners from either side. C C********************************************************************** C X PROGRAM DSYS C C This program uses the Lanczos algorithm with lookahead to compute C solutions of linear systems. This is just an example driver code. C It includes code to handle preconditioning from both sides. The C following routines are required from the user: C C SUBROUTINE GETMAT C This is the first routine called by this driver; it is used to C initialize all the matrix data. This routine must set the C global variable NROW to the dimension of the matrix. C SUBROUTINE AXB (X,B) C Computes B = A * X. C SUBROUTINE ATXB (X,B) C Computes B = A^T * X. C SUBROUTINE M1I (X,WRK) C Computes X = M_1^{-1} * X. WRK is just a work array. C SUBROUTINE M2I (X,WRK) C Computes X = M_2^{-1} * X. WRK is just a work array. C SUBROUTINE M1T (X,WRK) C Computes X = M_1^{-T} * X. WRK is just a work array. C SUBROUTINE M2T (X,WRK) C Computes X = M_2^{-T} * X. WRK is just a work array. C DOUBLE PRECISION FUNCTION DETA(N) C Computes one of the inner vector recursion coefficients -- see C the DLAL routine for details. C DOUBLE PRECISION FUNCTION DZETA(N) C Computes one of the inner vector recursion coefficients -- see C the DLAL routine for details. C DOUBLE PRECISION FUNCTION GETOMG(N) C Computes the scaling factors OMEGA -- see the SYSLAL routine C for details. C C The driver will ask the user for various run-time parameters, and C will read the initial data from the following files: C C x.dat = the starting guess X_0 C v.dat = the right hand side vector B C w.dat = the first Lanczos vector W_1 C C Note that the file names are in lower case (for systems where the C case is significant, such as Unix). All these vectors are assumed C to be of length NROW, as set by GETMAT. The entries of the vector C appear in order, one per line. It is the responsibility of the C user to ensure that there is enough data in the files. C C NOTE: This code uses an input format that, while valid on the Sun C and Cray compilers, might not be accepted by other compilers. In C particular, the construct C WRITE (6,'(A30,$)') 'This is a test' C is used to prevent the output processor from moving to the next C line after writing the text. If this construct is not supported C by the compiler, remove the dollar sign ($). C Also, the user input in this code is not bullet-proof. It assumes C that the user will provide valid inputs, i.e., numbers where they C are expected, etc. Providing invalid input type will likely crash C the program. C C Noel M. Nachtigal C July 16, 1990 C C********************************************************************** C #include "dlal.inc" C C********************************************************************** C C These are preprocessor definitions specific to linear systems. C #define _B_(I) VW(I,2*M+3) #define _X_(I) VW(I,2*M+4) C C********************************************************************** C X INCLUDE 'dimblk.inc' X INCLUDE 'precon.inc' C C Lanczos related variables and data parameters. C X INTEGER HDIM, M X PARAMETER (HDIM = 5000, M = 5) X INTEGER INFO, NLEN, NLIM, Q(HDIM) X DOUBLE PRECISION ANORM, SC(6,M), TCON X DOUBLE PRECISION VW(NDIM,3*M+6), WK(M,5*M+14) C C Linear systems' specific variables. C X DOUBLE PRECISION X0(NDIM) C C Local variables. C X CHARACTER*1 ANS X INTEGER I X DOUBLE PRECISION DTMP1 C C Initialize the matrix and get its norm. C X 10 CALL GETMAT X NLEN = NROW X 20 WRITE (6,'(A31,$)') 'Enter estimated matrix norm : ' X READ (5,*) ANORM C C Get the convergence tolerance. C X WRITE (6,'(A31,$)') 'Enter convergence tolerance : ' X READ (5,*) TCON C C Get the maximum number of Lanczos steps. C X WRITE (6,'(A31,$)') 'Maximum number of steps NLIM : ' X READ (5,*) NLIM X IF (NLIM.GT.HDIM) THEN X NLIM = HDIM X WRITE (6,'(A33)') 'NLIM exceeds the dimensions of H;' X WRITE (6,'(A18,I10)') 'NLIM adjusted to: ',NLIM X END IF C C Initialize the array of indices. For fun, we do not set up the C indices in increasing order; rather, we set them up so that the C various arrays will be filled from the end down. C X DO 30 I = 1, NLIM X Q(NLIM-I+1) = MOD(I-1,M)+1 X 30 CONTINUE C C Get the preconditioner information. C X WRITE (6,'(A31,A40)') 'Preconditioner: ', PNAME X WRITE (6,'(A31,$)') 'Precondition (1=Yes, 0=No) ? ' X READ (5,*) PRECON X IF (PRECON.EQ.1) THEN X CALL PSETUP X ELSE X PRECON = 0 X END IF C C Read in the vector x_0. C X OPEN (10,FILE = 'x.dat') X DO 40 I = 1, NLEN X READ (10,*) X0(I) X 40 CONTINUE X CLOSE (10) C C Read in the vector b. C X OPEN (10,FILE = 'v.dat') X DO 50 I = 1, NLEN X READ (10,*) _B_(I) X 50 CONTINUE X CLOSE (10) C C Read in the vector W(:,1). C X OPEN (10,FILE = 'w.dat') X DO 60 I = 1, NLEN X READ (10,*) _X_(I) X 60 CONTINUE X CLOSE (10) X CALL DCOPY (NLEN,_X_(1),1,_W_(1),1) C C Zero out x_0. C X CALL DSCAL (NLEN,0.0D0,_X_(1),1) C C Compute the modified right hand side. We set PRECON to 0, to use C the unpreconditioned matrix, and then restore it to its previous C value afterwards. C X I = PRECON X PRECON = 0 X CALL AXB (X0(1),_V_(1)) X PRECON = I X DTMP1 = -1.0 X CALL DAXPY (NLEN,DTMP1,_V_(1),1,_B_(1),1) X IF (PRECON.EQ.1) CALL M1I (_B_(1),_V_(1)) C C Set up the initial residual in V_1. C X CALL DCOPY (NLEN,_B_(1),1,_V_(1),1) C C Open the output files. C X INFO = 1151106 X OPEN (11,FILE = 'res.out') X OPEN (15,FILE = 'H.out') C C Call the linear solver. C X CALL SYSLAL (NDIM,NLEN,NLIM,M,VW,SC,WK,Q,TCON,ANORM,INFO) C C Check why we stopped. C X IF (INFO.LT.0) THEN X WRITE (6,'(A40,I5)') X $ 'Error encountered in the DSVDC routine: ', -INFO X ELSE IF (INFO.EQ.NO_ERROR) THEN X WRITE (6,'(A32)') 'The residual norm has converged.' X ELSE IF (INFO.EQ.CSI_ZERO) THEN X WRITE (6,'(A41)') 'An A^T-invariant subspace has been found.' X ELSE IF (INFO.EQ.SIG_ZERO) THEN X WRITE (6,'(A39)') 'An A-invariant subspace has been found.' X ELSE IF (INFO.EQ.ALL_ZERO) THEN X WRITE (6,'(A41)') 'Both invariant subspaces have been found.' X ELSE IF (INFO.EQ.NO_CLOSE) THEN X WRITE (6,'(A35)') 'The last block could not be closed.' X ELSE IF (INFO.EQ.NO_CONVG) THEN X WRITE (6,'(A31)') 'The algorithm did not converge.' X ELSE IF (INFO.EQ.NO_INPUT) THEN X WRITE (6,'(A27)') 'Invalid inputs encountered.' X ELSE X WRITE (6,'(A19,I5)') 'Unknown INFO code: ', INFO X END IF C C Close the output files. C X CLOSE (11) X CLOSE (15) C C Compute X. C X IF (PRECON.EQ.1) CALL M2I (_X_(1),TMPV) X DTMP1 = 1.0 X CALL DAXPY (NLEN,DTMP1,_X_(1),1,X0(1),1) C C Dump X to file x.out. C X OPEN (11,FILE = 'x.out') X DO 80 I = 1, NLEN X WRITE(11,'(E25.17)') X0(I) X 80 CONTINUE X CLOSE (11) C C Do it again? C X WRITE (6,'(A22,$)') 'Play it again (Y/N) ? ' X READ (5,'(A1)') ANS X IF ((ANS.EQ.'Y').OR.(ANS.EQ.'y')) THEN X WRITE (6,'(A28,$)') 'Read another matrix (Y/N) ? ' X READ (5,'(A1)') ANS X IF ((ANS.EQ.'Y').OR.(ANS.EQ.'y')) GO TO 10 X GO TO 20 X END IF C C That's all, folks. C X STOP X END C C********************************************************************** SHAR_EOF chmod 0600 dble/lal/dsys.F || echo 'restore of dble/lal/dsys.F failed' Wc_c="`wc -c < 'dble/lal/dsys.F'`" test 8607 -eq "$Wc_c" || echo 'dble/lal/dsys.F: original size 8607, current size' "$Wc_c" fi # ============= dble/lal/dsysbcg.F ============== if test -f 'dble/lal/dsysbcg.F' -a X"$1" != X"-c"; then echo 'x - skipping dble/lal/dsysbcg.F (File already exists)' else echo 'x - extracting dble/lal/dsysbcg.F (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/lal/dsysbcg.F' && C********************************************************************** C C Copyright (C) 1991 Roland W. Freund and Noel M. Nachtigal C All rights reserved. C C This code is part of a copyrighted package. For details, see the C file `cpyrit.doc' in the current directory. C C ***************************************************************** C ANY USE OF THIS CODE CONSTITUES ACCEPTANCE OF THE TERMS OF THE C COPYRIGHT NOTICE C ***************************************************************** C C********************************************************************** C C This file contains the routines for the QMR algorithm. SYSLAL is C the basic routine used to solve linear systems with QMR. BCKSUB C is a triangular matrix solver geared towards the setup used by C the Lanczos code (in particular, vector wrapping). C C********************************************************************** C X SUBROUTINE SYSLAL (NDIM,NLEN,NLIM,M,VW,SC,WK,Q,TCON,ANORM,INFO) C C Purpose: C This subroutine uses the Lanczos algorithm, combined with the QMR C algorithm, to solve linear systems. It runs the QMR algorithm to C convergence or until a user-specified iteration limit is reached. C If the algorithm converges, the routine returns the better of the C QMR or BCG iterates. The caller initializes the following: C VW(:,Q(1)) = the first Lanczos vector V_1, the residual for C the initial guess C VW(:,M+Q(1)) = the first Lanczos vector W_1 C VW(:,2*M+3) = the right hand side vector B C Q = the array of wrapped indices C TCON = convergence tolerance (optional) C ANORM = estimate for the norm of the matrix (optional) C INFO = the output units, if any C If the user provides a non-positive value for TCON, then 1.0E-6 C is used. C C Parameters: C NDIM = the dimensioned size of the array VW. Must be NDIM >= 1; C checked for validity (input). C NLEN = the actual size of the Lanczos vectors V and W; this also C implicitly determines the size of the matrix A. Must be C 1 <= NLEN <= NDIM; checked for validity (input). C NLIM = the maximum number of iterations the algorithm can take. C Must be NLIM >= 1; checked for validity. On exit, it is C the index of the last step taken or attempted, depending C on INFO, see below (input/output). C M = the maximum number of Lanczos vectors that can be stored C in the array VW. It is related to the size of the largest C block that can be built. The algorithm runs out of memory C when the number of vectors in two consecutive blocks C reaches M. Must be M >= 3; checked for validity (input). C VW = work array dimensioned (NDIM,3*M+6) words. It is used to C store the Lanczos vectors V in VW(:,1:M), the vectors W C in VW(:,M+1:2*M), two temporary vectors used by DLAL in C VW(:,2*M+1) and VW(:,2*M+2), the right hand side vector B C in VW(:,2*M+3), the current solution X_N in WV(:,2*M+4), C a pair of QMR direction vectors in VW(:,2*M+5:2*M+6), and C the update direction vectors PR in VW(:,2*M+7:3*M+6). C The Lanczos vectors V and W and the direction vectors PR C are stored wrapped, i.e., V_N is stored in VW(:,Q(N)) and C W_N is stored in VW(:,M+Q(N)), where Q(N) is assumed to C be a wrapped index array -- see below (input/output). C SC = work array dimensioned (6,M), used to store the various C scale factors. We have: C SC(1,i) = S(i) / S(i-1) C SC(2,i) = T(i) / T(i-1) C SC(3,i) = S(i) / T(i) C SC(4,i) = T(i) / S(i) C SC(6,i) = CSI(i) C SC(6,i) = SIG(i) C Note that the scale routine DSCALE expects to receive the C scale factors in a 6x1 vector as the one described above. C This routine initializes the first column; thereafter, C the DLAL routine will update the array (input/output). C WK = work array dimensioned (M,4*M+16), used to store internal C variables. We have: C WK(:,1:M) = (W_{NK}^T V_{NK}) C WK(:,M+1) to WK(:,2*M) C = work array for the QR and SVD routines C WK(:,2*M+1) = temporary vector C WK(:,2*M+2) = temporary vector C WK(:,2*M+3) = temporary vector C WK(:,2*M+4) = temporary vector C WK(:,2*M+5) = last column of the inverse C (W_{NK}^T V_{NK})^{-1} C WK(:,2*M+6) = H(NK:NKP1,N) C WK(:,2*M+7) = H(NK:NKP1,N+1) C WK(:,2*M+8) = the saved part of H(N), used in case C the block is restarted C WK(:,2*M+9) = the saved part of H(NP1), used in C case the block is restarted C WK(:,2*M+10) = the saved part of H(N), used in case C the norm is updated C WK(:,2*M+11) = the saved part of H(NP1), used in C case the norm is updated C WK(:,2*M+12) = the scale factors OMEGA (wrapped) C WK(:,2*M+13) = the cosines of the Givens rotations C (wrapped) C WK(:,2*M+14) = the sines of the Givens rotations C (wrapped) C WK(:,2*M+15) = the rotated right hand side for the C least squares problem (wrapped) C WK(:,2*M+16) = the elements of the row vectors ZNK C (wrapped) C WK(:,2*M+17) to WK(:,3*M+16) C = the matrix Y_NK (wrapped) C WK(:,3*M+17) to WK(:,4*M+16) C = the matrix R_NK (wrapped) C (input/output). C Q = integer array specifying the indices for all the wrapped C variables (V,W,SC,WK). To allow the algorithm to run more C than M steps, these variable wrap around, in that Q(I) is C the index of the slots where the variables are stored at C the I-th step. Normally, these indices would be in order, C basically Q(I) = I MOD M + 1, but the algorithm makes no C assumptions to this effect. These indices are not checked C in any way for validity (input). C TCON = relative convergence tolerance. If the user provides a C non-positive value, then 1.0E-06 is used (input). C ANORM = user-supplied estimate for the norm of A. On exit, it is C set to the last value used by the algorithm. The value is C updated by the algorithm whenever it needs to close a C block (input/output). C INFO = information passing variable. C Upon entry, it gives the numbers of the output units used C to trace execution, and controls the generation of the C convergence history. If INFO is represented as txxyyzz, C then: C t = if not 0, then the true residual norm is computed C at every step by computing the iterate, then its C residual, and finally the norm. C xx = if not 0, then it denotes the unit number for the C unit to which the block tridiagonal matrix H is C output. The data is output in blocks, each column C at a time, one number per line. The first number C in each block is an integer denoting the starting C row index; the second number is also an integer C denoting both the ending row number and the index C of the column. Finally, there is one number for C each row in the range, a real in format E25.17. C Since each column is output before it is known C whether the block will be closed or not, it can C happen that data for the same column will appear C more than once in the file. Only the last listing C is valid; care must be taken to ensure that no C data from a previous listing is retained in the C column. C yy = if not 0, then it denotes the unit number for the C unit to which convergence history data is sent. C The data is sent as six numbers on a line: first C an integer (I8) denoting the iteration number, C followed by an integer (I3) denoting the block C size so far, then six reals (E11.4) specifying C in order the QMR residual norm upper bound, the C last computed QMR residual norm, the BCG residual C norm estimate, the last computed BCG residual C norm, the smallest singular value of the current C block, and the matrix norm estimate. Again, data C for the same iteration may appear more than once, C due to blocks not closing, and only the last data C is significant. C zz = if not 0, then it denotes the unit number for the C unit to which verbose trace messages are sent. In C general, these messages are meant for interactive C execution tracing. In addition to the convergence C data that appears in the same format as for unit C yy (see above), the routine will also output data C about why blocks are built, etc. C For example: C INFO = 1106 ==> trace messages are sent to unit 6, C convergence data sent to unit 11 C INFO = 1000000 ==> the true residual norm is always C computed C INFO = 5121314 ==> always compute true residual norm, C send trace messages to unit 14, the C convergence data to unit 13, and H C to unit 12 C INFO = 0 ==> no output. C It is the responsibility of the caller to ensure that the C units used are ready for output. C Upon exit: C INFO = 0 ==> nothing to report, algorithm converged C INFO < 0 ==> the SVD routine returned this error code C in DLAL (with positive sign) C INFO = 1 ==> an A-invariant subspace has been found C INFO = 2 ==> an A^T-invariant subspace has been found C INFO = 3 ==> both subspaces have been found C INFO = 4 ==> the norm estimate was updated C INFO = 8 ==> the last block could not be closed C INFO = 16 ==> algorithm failed to converge after NLIM C steps C INFO = 32 ==> invalid inputs C For more details, see the description in the routine DLAL C (input/output). C C External routines used: C subroutine axb(x,b) C Computes b = A * x. C subroutine atxb(x,b) C Computes b = A^T * x. C subroutine bcksub(ndim,nlen,nstart,a,xb,q) C Computes xb = inv(a) * xb with a upper triangular (specific to C our setup, i.e., the columns of a are permuted according to q). C subroutine daxpy(n,da,dx,incx,dy,incy) C Computes dy = da * dx + dy. C subroutine dcopy(n,dx,incx,dy,incy) C Computes dy = dx. C double precision ddot(n,dx,incx,dy,incy) C Computes the dot product of dx and dy. C double precision deps() C Returns machine epsilon. C subroutine dlal(ndim,nlen,m,n,nk,nkm1,vw,sc,wk,q,norms,tol,info) C Does one step of the look-ahead Lanczos algorithm. C double precision dnrm2(n,dx,incx) C Computes the 2-norm of dx. C subroutine drot(n,dx,incx,dy,incy,dcos,dsin) C Applies a Givens rotation to a vector. C subroutine drotg(da,db,dcos,dsin) C Computes a Givens rotation. C subroutine dscal(n,da,dx,incx). C Computes dx = da * dx. C subroutine dscale(n,v,w,sc,tol) C Scales the Lanczos vectors v and w. C double precision getomg(n) C Computes the scaling factor OMEGA_n. C C Noel M. Nachtigal C October 24, 1990 C C********************************************************************** C #include "dlal.inc" C C********************************************************************** C C These are preprocessor definitions specific to linear systems. C #define _B_(I) VW(I,2*M+3) #define _X_ VW(1,2*M+4) #define _PN_ VW(1,2*M+5+PIDX) #define _PR_(I) VW(1,2*M+6+Q(I)) C #define _OMG_(I) WK(Q(I),2*M+12) #define _COS_(I) WK(Q(I),2*M+13) #define _SIN_(I) WK(Q(I),2*M+14) #define _RHS_(I) WK(Q(I),2*M+15) #define _ZNK_(I) WK(Q(I),2*M+16) #define _YNK_(I,J) WK(I,2*M+16+Q(J)) #define _RNKALL_ WK(1,3*M+17) #define _RNK_(I,J) WK(I,3*M+16+Q(J)) C C********************************************************************** C X INTRINSIC FLOAT, MAX, SQRT C X EXTERNAL DDOT, DEPS, DNRM2, GETOMG X DOUBLE PRECISION DDOT, DEPS, DNRM2, GETOMG C X INTEGER INFO, M, NLEN, NLIM, NDIM, Q(NLIM) X DOUBLE PRECISION ANORM, SC(6,M), TCON X DOUBLE PRECISION VW(NDIM,3*M+6), WK(M,4*M+16) C C Local variables. C X INTEGER LNK, LNKM1, LNKM2, N, NK, NKM1, NSAV, ONK, ONKM1, ONKM2 X INTEGER I, J, HBASE, HF, TF, TRES, VF, PIDX X DOUBLE PRECISION BCGBAS, BCGEST, BCGRES X DOUBLE PRECISION DTMP1, DTMP2, MAXOMG, NORMS(3), R0, RESN X DOUBLE PRECISION MULTB, MULTQ, SAVRHS, TMPRHS, TOL(4) X LOGICAL COMPTB, COMPTQ, CONVRG C C Extract the output units HF, TF, and VF from INFO, and the true C residual flag TRES. C X TRES = INFO / 1000000 X INFO = INFO - TRES * 1000000 X HF = INFO / 10000 X INFO = INFO - HF * 10000 X TF = INFO / 100 X INFO = INFO - TF * 100 X VF = INFO C C Check whether the inputs are valid. C X INFO = NO_ERROR X IF (NDIM.LT.1) INFO = NO_INPUT X IF (NLEN.LT.1) INFO = NO_INPUT X IF (NLEN.GT.NDIM) INFO = NO_INPUT X IF (NLIM.LT.1) INFO = NO_INPUT X IF (M.LT.3) INFO = NO_INPUT X IF (INFO.NE.NO_ERROR) RETURN C C Check the convergence tolerance and the singular values tolerance. C X IF (TCON.LE.0.0D0) TCON = 0.000001D0 C C Set up the Lanczos tolerances. C X DTMP1 = DEPS() X TMIN = SQRT(DTMP1) X TMAX = 1.0D0 / TMIN X TNRM = SQRT(TMIN) X TSVD = DTMP1 C C Initialize the counters. C X N = 1 X NK = 1 X NKM1 = 1 C C Scale the first pair of Lanczos vectors. C X CSI(1) = 1.0D0 X SIG(1) = 1.0D0 X ST(1) = 1.0D0 X CALL DSCALE (NLEN,_V_(1),_W_(1),SC(1,Q(1)),TOL) C C Check for invariant subspaces (already?). C X INFO = NO_ERROR X IF (CSI(1).EQ.-1.0D0) INFO = INFO + CSI_ZERO X IF (SIG(1).EQ.-1.0D0) INFO = INFO + SIG_ZERO X IF (INFO.NE.NO_ERROR) RETURN C C Initialize the QMR save vector index. C X PIDX = 0 C C Initialize the bound multipliers. C X MULTB = 1.0D0 X MULTQ = 1.0D0 C C Set up WTV(1,1). C X WTV(1,1) = DDOT(NLEN,_V_(1),1,_W_(1),1) X WTV(1,1) = SIG(1) * CSI(1) * WTV(1,1) C C Set up the first element of the right-hand side. C X _OMG_(1) = GETOMG(1) X _RHS_(1) = _OMG_(1) * _S_(1) X MAXOMG = 1.0D0 / _OMG_(1) C C Initialize the norm estimate. C X NORMS(1) = ANORM X NORMS(2) = 0.0D0 C C Compute and save the initial residual norm in R0. C X RESN = 1.0D0 X R0 = DNRM2(NLEN,_V_(1),1) C C Initialize the BCG residual norm and estimate. C X BCGEST = 1.0D0 X BCGRES = 1.0D0 X BCGBAS = _OMG_(1) C C Start the trace messages and convergence history. C X NORMS(3) = 1.0D0 X DTMP1 = RESN X IF (VF.NE.0) WRITE (VF,'(I8,I3,6E11.4)') N, N-ONK, DTMP1, X $ RESN, BCGEST, BCGRES, NORMS(3), NORMS(1) X IF (TF.NE.0) WRITE (TF,'(I8,I3,6E11.4)') N, N-ONK, DTMP1, X $ RESN, BCGEST, BCGRES, NORMS(3), NORMS(1) C C Check for convergence (already?). C X IF (TCON.GE.1.0D0) THEN X INFO = NO_ERROR X RETURN X END IF C C Iterate. C X 10 ONK = NK X ONKM1 = NKM1 C C If we have closed a block, save the working variables, in case we C need to restart. Also, reset the norm estimator. C X IF (N.EQ.NK) THEN X CALL DCOPY (N-NKM1+1,H_NP1,1,HNP1SAV,1) X CALL DCOPY (N-ONKM1+1,H_N(1),1,HNSAV,1) X SAVRHS = _RHS_(N) X NORMS(2) = 0.0D0 X NSAV = N X END IF C C Check whether we have enough room left in the arrays. C X 20 INFO = NO_ERROR X IF (N-NKM1+2.GE.M) INFO = 1 X IF ((INFO.NE.NO_ERROR).AND.(VF.NE.0)) THEN X WRITE (VF,'(A39)') 'Block is maximal, recommending closure.' X END IF C C Compute the matrix vector products. C X CALL AXB (_V_(N), _V_(N+1)) X CALL ATXB (_W_(N), _W_(N+1)) C C Save the block info. C X CALL DCOPY (N-NKM1+1,H_NP1,1,HNP1TMP,1) X CALL DCOPY (N-ONKM1+1,H_N(1),1,HNTMP,1) X TMPRHS = _RHS_(N) C C Do one step of the Lanczos algorithm. C X CALL DLAL (NDIM,NLEN,M,N,NK,NKM1,VW,SC,WK,Q,NORMS,TOL,VF,INFO) C C Set ANORM to the current value of the norm estimate. C X ANORM = NORMS(1) C C Check the info passing variable. C We check whether the DSVDC routine reported errors, whether the C block did not close when it was maximal, or whether an invariant C subspace was found. C X IF (INFO.LT.0) THEN X NLIM = N X RETURN X ELSE IF (INFO.EQ.CSI_ZERO) THEN X NLIM = N X ELSE IF (INFO.EQ.SIG_ZERO) THEN X NLIM = N X ELSE IF (INFO.EQ.ALL_ZERO) THEN X NLIM = N X ELSE IF (INFO.EQ.NORM_UPD) THEN X NSAV = N-1 X SAVRHS = TMPRHS X INFO = NO_CONVG X CALL DCOPY (N-NKM1,HNP1TMP,1,HNP1SAV,1) X CALL DCOPY (N-ONKM1,HNTMP,1,HNSAV,1) X IF (VF.NE.0) WRITE (VF,'(A20)') 'Norm updated.' X ELSE IF (INFO.EQ.NO_CLOSE) THEN X N = NK X IF (VF.NE.0) WRITE (VF,'(A20)') 'Block did not close:' C C Block did not close, do we have another norm estimate? C X IF (NORMS(2).EQ.0.0D0) THEN X IF (VF.NE.0) WRITE (VF,'(A47)') X $ '==> no new norm estimates available (aborting).' X NLIM = N X RETURN X ELSE C C Update the norm --- the block is guaranteed to close now. We then C restart the block from the last update point. C X NORMS(1) = NORMS(2) X IF (VF.NE.0) WRITE (VF,'(A30, E16.8)') X $ '==> updating norm estimate to ', NORMS(1) X N = NSAV X NORMS(2) = 0.0D0 X _RHS_(N) = SAVRHS X CALL DCOPY (N-NKM1+1,HNP1SAV,1,H_NP1,1) X CALL DCOPY (N-ONKM1+1,HNSAV,1,H_N(1),1) X GO TO 20 X END IF X INFO = NO_CONVG X ELSE X INFO = NO_CONVG X END IF C C Get the next scaling factor OMEGA(NP1) and update MAXOMG. C X _OMG_(N) = GETOMG(N) X MAXOMG = MAX(MAXOMG,1.0D0/_OMG_(N)) C C Output the matrix H. C X IF (HF.NE.0) THEN X WRITE (HF,'(I20)') ONKM1 X WRITE (HF,'(I20)') N X WRITE (HF,'(E25.17)') (H_N(I-ONKM1+1),I=ONKM1,N) X END IF C C Compute the starting index in H(:,N-1). C X HBASE = MAX(1,ONKM1-1) C C Multiply the column of H by the OMEGAs and apply all the previous C rotations. C X H_N(1) = _OMG_(HBASE) * H_N(1) C C If we are beyond the first block, then there is fill-in above the C top element in this column of H. This element is saved in ZNK. C X IF (ONKM1.GT.1) THEN X DTMP1 = 0.0D0 X CALL DROT (1,DTMP1,1,H_N(1),1, X $ _COS_(ONKM1),_SIN_(ONKM1)) X _ZNK_(N-1) = DTMP1 X END IF C C Apply the rotations to the rest of the column. C X DO 30 I = ONKM1+1, N-1 X J = I - ONKM1 X H_N(J) = _OMG_(I) * H_N(J) X CALL DROT (1,H_N(J),1,H_N(J+1),1, X $ _COS_(I),_SIN_(I)) X 30 CONTINUE C C H(N) is not reached by the any of the rotations. Multiply it by C its OMEGA and compute the rotation for the column. This will also C apply it. C X J = N - ONKM1 X H_N(J) = _OMG_(N) * H_N(J) X CALL DROTG (H_N(J),H_N(J+1), X $ _COS_(N),_SIN_(N)) C C Apply it to the right-hand side as well. C X _RHS_(N) = 0.0D0 X CALL DROT (1,_RHS_(N-1),1,_RHS_(N),1, X $ _COS_(N),_SIN_(N)) C C Extract the next column of Y_{NK}. C X IF (ONK.GT.ONKM1) THEN X CALL DCOPY (ONK-ONKM1,H_N(1),1,_YNK_(1,N-1),1) X END IF C C Extract the next column of R_{NK}. C X CALL DCOPY (N-ONK,H_N(ONK-ONKM1+1),1,_RNK_(1,N-1),1) C C Set up the work vector for the next step. C X CALL DCOPY (N-NKM1+1,H_NP1,1,H_N(1),1) C C If we haven't closed a block, compute just the new bound. C X IF (NK.EQ.ONK) THEN X DTMP1 = SQRT(FLOAT(N)) * MAXOMG * ABS(_RHS_(N)) / R0 C C If we have closed a block, update the solution. C X ELSE C C Compute the lengths of the blocks. C X LNK = N - ONK X LNKM1 = ONK - ONKM1 X LNKM2 = ONKM1 - ONKM2 C C Zero out P_{NK} R_{NK}. C X DO 40 I = ONK, N-1 X CALL DSCAL (NLEN,0.0D0,_PR_(I),1) X 40 CONTINUE C C Compute the term involving P_{NKM2}. C X IF (ONKM1.GT.1) THEN X DO 50 I = ONK, N-1 X CALL DCOPY (NLEN,_PN_,1,_PR_(I),1) X CALL DSCAL (NLEN,-_ZNK_(I),_PR_(I),1) X 50 CONTINUE X END IF C C Compute the term involving P_{NKM1}. C X IF (ONK.GT.ONKM1) THEN X DO 70 I = ONK, N-1 C C Compute the next column of R_{NKM1}^{-1} * Y_{NK}. C X CALL BCKSUB (M,LNKM1,ONKM1,_RNKALL_, X $ _YNK_(1,I),Q) C C Multiply ( P_{NKM1} R_{NKM1} ) by the new column and add to the C appropriate column of ( P_{NK} R_{NK} ). C X DO 60 J = 1, LNKM1 X CALL DAXPY (NLEN,-_YNK_(J,I), X $ _PR_(ONKM1+J-1),1,_PR_(I),1) X 60 CONTINUE X 70 CONTINUE X END IF C C Now add V_{NK} into ( P_{NK} R_{NK} ). We also use this loop to C copy the right hand side of the least squares problem to a work C vector. C X DO 80 I = ONK, N-1 X CALL DAXPY (NLEN,SIG(I),_V_(I),1, X $ _PR_(I),1) X _YNK_(I-ONK+1,ONK) = _RHS_(I) X 80 CONTINUE C C Compute R_{NK}^{-1} * RHS. C X CALL BCKSUB (M,LNK,ONK,_RNKALL_,_YNK_(1,ONK),Q) C C Update the solution vector and the base of the BCG norm estimate. C X DO 90 I = ONK, N-1 X BCGBAS = BCGBAS * _SIN_(I+1) X CALL DAXPY (NLEN,_YNK_(I-ONK+1,ONK), X $ _PR_(I),1,_X_,1) X 90 CONTINUE C C Compute the last column of R_{NK}^{-1}. C X CALL DSCAL (M,0.0D0,_YNK_(1,ONK),1) X _YNK_(LNK,ONK) = 1.0D0 X CALL BCKSUB (M,LNK,ONK,_RNKALL_,_YNK_(1,ONK),Q) C C Compute P_N and save it for later use. C X CALL DCOPY (NLEN,_PR_(ONK),1,_PN_,1) X CALL DSCAL (NLEN,_YNK_(1,ONK),_PN_,1) X DO 100 I = ONK+1, N-1 X CALL DAXPY (NLEN,_YNK_(I-ONK+1,ONK), X $ _PR_(I),1,_PN_,1) X 100 CONTINUE C C Compute the QMR residual norm upper bound and set the flag. C X DTMP1 = SQRT(FLOAT(N)) * MAXOMG * ABS(_RHS_(N)) / R0 X CONVRG = DTMP1.LE.TCON C C Compute the BCG residual norm estimate, if a BCG iterate exists. C X IF (ABS(_COS_(N)).LE.TMIN) THEN X BCGEST = -1.0D0 X ELSE X BCGEST = ABS(BCGBAS / (_OMG_(N)*_COS_(N))) X BCGRES = BCGEST X ENDIF C C See if we need to compute the true residual norms. For BCG, we C compute it the true residual norm when the estimate is within a C factor of 2 of the convergence tolerance. For QMR, we compute C the true residual norm when the estimate is within a factor of 10 C of the convergence tolerance. We also compute both norms if the C user has requested it by setting TRES. C X COMPTB = (TRES.NE.0).OR.(MULTB*BCGRES/TCON.LE.2.0D0) X COMPTQ = (TRES.NE.0).OR.(MULTQ*DTMP1/TCON.LE.10.0D0) C C Now compute the various norms, if necessary. First, compute QMR. C X IF (COMPTQ) THEN X CALL AXB (_X_,TMPW) X DTMP2 = -1.0D0 X CALL DAXPY (NLEN,DTMP2,_B_(1),1,TMPW,1) X RESN = DNRM2(NLEN,TMPW,1) / R0 X IF (DTMP1/RESN.LT.1.0D0) MULTQ = RESN / DTMP1 X CONVRG = (CONVRG).OR.(RESN.LE.TCON) X END IF C C Next, compute the BCG solution and its residual norm. C X IF (COMPTB) THEN X CALL DCOPY (NLEN,_X_,1,TMPV,1) X BCGRES = _RHS_(N-1) * X $ (_SIN_(N) / _COS_(N))**2 X DO 110 I = ONK, N-1 X DTMP2 = BCGRES * _YNK_(I-ONK+1,ONK) X CALL DAXPY (NLEN,DTMP2,_PR_(I),1,TMPV,1) X 110 CONTINUE X CALL AXB (TMPV,TMPW) X DTMP2 = -1.0D0 X CALL DAXPY (NLEN,DTMP2,_B_(1),1,TMPW,1) X BCGRES = DNRM2(NLEN,TMPW,1) / R0 X IF (BCGEST/BCGRES.LT.1.0D0) MULTB = BCGRES / BCGEST X CONVRG = (CONVRG).OR.(BCGRES.LE.TCON) X END IF C C Check for convergence. C X IF (CONVRG) THEN X INFO = NO_ERROR X NLIM = N X IF (BCGRES.LT.RESN) THEN X CALL DCOPY (NLEN,TMPV,1,_X_,1) X END IF X END IF C C Update ONKM2 and the QMR saved vector index. C X PIDX = 1 - PIDX X ONKM2 = ONKM1 X END IF C C Output the trace messages and convergence history. C X IF (VF.NE.0) WRITE (VF,'(I8,I3,6E11.4)') N, N-ONK, DTMP1, X $ RESN, BCGEST, BCGRES, NORMS(3), NORMS(1) X IF (TF.NE.0) WRITE (TF,'(I8,I3,6E11.4)') N, N-ONK, DTMP1, X $ RESN, BCGEST, BCGRES, NORMS(3), NORMS(1) C C Iterate up to NLIM steps. C X IF (N.LT.NLIM) GO TO 10 C C Output the multipliers. C X IF (VF.NE.0) THEN X IF (MULTB.GT.1.0D0) WRITE (VF,'(A26,E9.2)') X $ 'BCG res bound multiplier: ', MULTB X IF (MULTQ.GT.1.0D0) WRITE (VF,'(A26,E9.2)') X $ 'QMR res bound multiplier: ', MULTQ X END IF C X RETURN X END C C********************************************************************** C X SUBROUTINE BCKSUB (NDIM,NLEN,NSTART,A,XB,Q) C C Purpose: C Computes XB = inv(A) * XB, where A is upper triangular. C C Parameters: C NDIM = the dimensioned size of A (input). C NLEN = the actual size of A (input). C NSTART = the starting column index for A (input). C A = array containing the matrix of interest starting in the C column NSTART and possibly wrapping around as indicated C by Q (input). C XB = upon entry, the right hand side vector; upon exit, the C solution. XB is not wrapped (input/output). C Q = integer array specifying the actual indices for wrapping C purposes. Q(i) is the true index in A of the ith column C of the matrix of interest (input). C C Noel M. Nachtigal C October 8, 1990 C X INTEGER NDIM, NLEN, NSTART, Q(*) X DOUBLE PRECISION A(NDIM,*), XB(*) C C Local variables. C X INTEGER I, ILAST, ITMP, J X DOUBLE PRECISION DTMP C C Do the elimination; the only trick here is to keep track of the C wrapped columns of A, i.e., A(:,J) is stored in A(:,Q(J)). C X ILAST = NSTART + NLEN - 1 X XB(NLEN) = XB(NLEN) / A(NLEN,Q(ILAST)) X DO 20 I = ILAST-1, NSTART, -1 X DTMP = 0.0D0 X ITMP = I - NSTART + 1 X DO 10 J = I+1, ILAST X DTMP = DTMP + XB(J-NSTART+1) * A(ITMP,Q(J)) X 10 CONTINUE X XB(ITMP) = (XB(ITMP) - DTMP) / A(ITMP,Q(I)) X 20 CONTINUE C X RETURN X END C C********************************************************************** SHAR_EOF chmod 0600 dble/lal/dsysbcg.F || echo 'restore of dble/lal/dsysbcg.F failed' Wc_c="`wc -c < 'dble/lal/dsysbcg.F'`" test 28685 -eq "$Wc_c" || echo 'dble/lal/dsysbcg.F: original size 28685, current size' "$Wc_c" fi # ============= dble/lal/dsyslal.F ============== if test -f 'dble/lal/dsyslal.F' -a X"$1" != X"-c"; then echo 'x - skipping dble/lal/dsyslal.F (File already exists)' else echo 'x - extracting dble/lal/dsyslal.F (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/lal/dsyslal.F' && C********************************************************************** C C Copyright (C) 1991 Roland W. Freund and Noel M. Nachtigal C All rights reserved. C C This code is part of a copyrighted package. For details, see the C file `cpyrit.doc' in the current directory. C C ***************************************************************** C ANY USE OF THIS CODE CONSTITUES ACCEPTANCE OF THE TERMS OF THE C COPYRIGHT NOTICE C ***************************************************************** C C********************************************************************** C C This file contains the routines for the QMR algorithm. SYSLAL is C the basic routine used to solve linear systems with QMR. BCKSUB C is a triangular matrix solver geared towards the setup used by C the Lanczos code (in particular, vector wrapping). C C********************************************************************** C X SUBROUTINE SYSLAL (NDIM,NLEN,NLIM,M,VW,SC,WK,Q,TCON,ANORM,INFO) C C Purpose: C This subroutine uses the Lanczos algorithm, combined with the QMR C algorithm, to solve linear systems. It runs the QMR algorithm to C convergence or until a user-specified iteration limit is reached. C The caller initializes the following: C VW(:,Q(1)) = the first Lanczos vector V_1, the residual for C the initial guess C VW(:,M+Q(1)) = the first Lanczos vector W_1 C VW(:,2*M+3) = the right hand side vector B C Q = the array of wrapped indices C TCON = convergence tolerance (optional) C ANORM = estimate for the norm of the matrix (optional) C INFO = the output units, if any C If the user provides a non-positive value for TCON, then 1.0E-6 C is used. C C Parameters: C NDIM = the dimensioned size of the array VW. Must be NDIM >= 1; C checked for validity (input). C NLEN = the actual size of the Lanczos vectors V and W; this also C implicitly determines the size of the matrix A. Must be C 1 <= NLEN <= NDIM; checked for validity (input). C NLIM = the maximum number of iterations the algorithm can take. C Must be NLIM >= 1; checked for validity. On exit, it is C the index of the last step taken or attempted, depending C on INFO, see below (input/output). C M = the maximum number of Lanczos vectors that can be stored C in the array VW. It is related to the size of the largest C block that can be built. The algorithm runs out of memory C when the number of vectors in two consecutive blocks C reaches M. Must be M >= 3; checked for validity (input). C VW = work array dimensioned (NDIM,3*M+6) words. It is used to C store the Lanczos vectors V in VW(:,1:M), the vectors W C in VW(:,M+1:2*M), two temporary vectors used by DLAL in C VW(:,2*M+1) and VW(:,2*M+2), the right hand side vector B C in VW(:,2*M+3), the current solution X_N in WV(:,2*M+4), C a pair of QMR direction vectors in VW(:,2*M+5:2*M+6), and C the update direction vectors PR in VW(:,2*M+7:3*M+6). C The Lanczos vectors V and W and the direction vectors PR C are stored wrapped, i.e., V_N is stored in VW(:,Q(N)) and C W_N is stored in VW(:,M+Q(N)), where Q(N) is assumed to C be a wrapped index array -- see below (input/output). C SC = work array dimensioned (6,M), used to store the various C scale factors. We have: C SC(1,i) = S(i) / S(i-1) C SC(2,i) = T(i) / T(i-1) C SC(3,i) = S(i) / T(i) C SC(4,i) = T(i) / S(i) C SC(6,i) = CSI(i) C SC(6,i) = SIG(i) C Note that the scale routine DSCALE expects to receive the C scale factors in a 6x1 vector as the one described above. C This routine initializes the first column; thereafter, C the DLAL routine will update the array (input/output). C WK = work array dimensioned (M,4*M+16), used to store internal C variables. We have: C WK(:,1:M) = (W_{NK}^T V_{NK}) C WK(:,M+1) to WK(:,2*M) C = work array for the QR and SVD routines C WK(:,2*M+1) = temporary vector C WK(:,2*M+2) = temporary vector C WK(:,2*M+3) = temporary vector C WK(:,2*M+4) = temporary vector C WK(:,2*M+5) = last column of the inverse C (W_{NK}^T V_{NK})^{-1} C WK(:,2*M+6) = H(NK:NKP1,N) C WK(:,2*M+7) = H(NK:NKP1,N+1) C WK(:,2*M+8) = the saved part of H(N), used in case C the block is restarted C WK(:,2*M+9) = the saved part of H(NP1), used in C case the block is restarted C WK(:,2*M+10) = the saved part of H(N), used in case C the norm is updated C WK(:,2*M+11) = the saved part of H(NP1), used in C case the norm is updated C WK(:,2*M+12) = the scale factors OMEGA (wrapped) C WK(:,2*M+13) = the cosines of the Givens rotations C (wrapped) C WK(:,2*M+14) = the sines of the Givens rotations C (wrapped) C WK(:,2*M+15) = the rotated right hand side for the C least squares problem (wrapped) C WK(:,2*M+16) = the elements of the row vectors ZNK C (wrapped) C WK(:,2*M+17) to WK(:,3*M+16) C = the matrix Y_NK (wrapped) C WK(:,3*M+17) to WK(:,4*M+16) C = the matrix R_NK (wrapped) C (input/output). C Q = integer array specifying the indices for all the wrapped C variables (V,W,SC,WK). To allow the algorithm to run more C than M steps, these variable wrap around, in that Q(I) is C the index of the slots where the variables are stored at C the I-th step. Normally, these indices would be in order, C basically Q(I) = I MOD M + 1, but the algorithm makes no C assumptions to this effect. These indices are not checked C in any way for validity (input). C TCON = relative convergence tolerance. If the user provides a C non-positive value, then 1.0E-06 is used (input). C ANORM = user-supplied estimate for the norm of A. On exit, it is C set to the last value used by the algorithm. The value is C updated by the algorithm whenever it needs to close a C block (input/output). C INFO = information passing variable. C Upon entry, it gives the numbers of the output units used C to trace execution, and controls the generation of the C convergence history. If INFO is represented as txxyyzz, C then: C t = if not 0, then the true residual norm is computed C at every step by computing the iterate, then its C residual, and finally the norm. C xx = if not 0, then it denotes the unit number for the C unit to which the block tridiagonal matrix H is C output. The data is output in blocks, each column C at a time, one number per line. The first number C in each block is an integer denoting the starting C row index; the second number is also an integer C denoting both the ending row number and the index C of the column. Finally, there is one number for C each row in the range, a real in format E25.17. C Since each column is output before it is known C whether the block will be closed or not, it can C happen that data for the same column will appear C more than once in the file. Only the last listing C is valid; care must be taken to ensure that no C data from a previous listing is retained in the C column. C yy = if not 0, then it denotes the unit number for the C unit to which convergence history data is sent. C The data is sent as six numbers on a line: first C an integer (I8) denoting the iteration number, C followed by an integer (I3) denoting the block C size so far, then four reals (E11.4) specifying C in order the residual norm upper bound, the last C computed residual norm, the smallest singular C value of the current block, and the matrix norm C estimate. Again, data for the same iteration may C appear more than once, due to blocks not closing, C and only the last data is significant. C zz = if not 0, then it denotes the unit number for the C unit to which verbose trace messages are sent. In C general, these messages are meant for interactive C execution tracing. In addition to the convergence C data that appears in the same format as for unit C yy (see above), the routine will also output data C about why blocks are built, etc. C For example: C INFO = 1106 ==> trace messages are sent to unit 6, C convergence data sent to unit 11 C INFO = 1000000 ==> the true residual norm is always C computed C INFO = 5121314 ==> always compute true residual norm, C send trace messages to unit 14, the C convergence data to unit 13, and H C to unit 12 C INFO = 0 ==> no output. C It is the responsibility of the caller to ensure that the C units used are ready for output. C Upon exit: C INFO = 0 ==> nothing to report, algorithm converged C INFO < 0 ==> the SVD routine returned this error code C in DLAL (with positive sign) C INFO = 1 ==> an A-invariant subspace has been found C INFO = 2 ==> an A^T-invariant subspace has been found C INFO = 3 ==> both subspaces have been found C INFO = 4 ==> the norm estimate was updated C INFO = 8 ==> the last block could not be closed C INFO = 16 ==> algorithm failed to converge after NLIM C steps C INFO = 32 ==> invalid inputs C For more details, see the description in the routine DLAL C (input/output). C C External routines used: C subroutine axb(x,b) C Computes b = A * x. C subroutine atxb(x,b) C Computes b = A^T * x. C subroutine bcksub(ndim,nlen,nstart,a,xb,q) C Computes xb = inv(a) * xb with a upper triangular (specific to C our setup, i.e., the columns of a are permuted according to q). C subroutine daxpy(n,da,dx,incx,dy,incy) C Computes dy = da * dx + dy. C subroutine dcopy(n,dx,incx,dy,incy) C Computes dy = dx. C double precision ddot(n,dx,incx,dy,incy) C Computes the dot product of dx and dy. C double precision deps() C Returns machine epsilon. C subroutine dlal(ndim,nlen,m,n,nk,nkm1,vw,sc,wk,q,norms,tol,info) C Does one step of the look-ahead Lanczos algorithm. C double precision dnrm2(n,dx,incx) C Computes the 2-norm of dx. C subroutine drot(n,dx,incx,dy,incy,dcos,dsin) C Applies a Givens rotation to a vector. C subroutine drotg(da,db,dcos,dsin) C Computes a Givens rotation. C subroutine dscal(n,da,dx,incx). C Computes dx = da * dx. C subroutine dscale(n,v,w,sc,tol) C Scales the Lanczos vectors v and w. C double precision getomg(n) C Computes the scaling factor OMEGA_n. C C Noel M. Nachtigal C October 24, 1990 C C********************************************************************** C #include "dlal.inc" C C********************************************************************** C C These are preprocessor definitions specific to linear systems. C #define _B_(I) VW(I,2*M+3) #define _X_ VW(1,2*M+4) #define _PN_ VW(1,2*M+5+PIDX) #define _PR_(I) VW(1,2*M+6+Q(I)) C #define _OMG_(I) WK(Q(I),2*M+12) #define _COS_(I) WK(Q(I),2*M+13) #define _SIN_(I) WK(Q(I),2*M+14) #define _RHS_(I) WK(Q(I),2*M+15) #define _ZNK_(I) WK(Q(I),2*M+16) #define _YNK_(I,J) WK(I,2*M+16+Q(J)) #define _RNKALL_ WK(1,3*M+17) #define _RNK_(I,J) WK(I,3*M+16+Q(J)) C C********************************************************************** C X INTRINSIC FLOAT, MAX, SQRT C X EXTERNAL DDOT, DEPS, DNRM2, GETOMG X DOUBLE PRECISION DDOT, DEPS, DNRM2, GETOMG C X INTEGER INFO, M, NLEN, NLIM, NDIM, Q(NLIM) X DOUBLE PRECISION ANORM, SC(6,M), TCON X DOUBLE PRECISION VW(NDIM,3*M+6), WK(M,4*M+16) C C Local variables. C X INTEGER LNK, LNKM1, LNKM2, N, NK, NKM1, NSAV, ONK, ONKM1, ONKM2 X INTEGER I, J, HBASE, HF, TF, TRES, VF, PIDX X DOUBLE PRECISION DTMP1, DTMP2, MAXOMG, MULT, NORMS(3), R0, RESN X DOUBLE PRECISION SAVRHS, TMPRHS, TOL(4) C C Extract the output units HF, TF, and VF from INFO, and the true C residual flag TRES. C X TRES = INFO / 1000000 X INFO = INFO - TRES * 1000000 X HF = INFO / 10000 X INFO = INFO - HF * 10000 X TF = INFO / 100 X INFO = INFO - TF * 100 X VF = INFO C C Check whether the inputs are valid. C X INFO = NO_ERROR X IF (NDIM.LT.1) INFO = NO_INPUT X IF (NLEN.LT.1) INFO = NO_INPUT X IF (NLEN.GT.NDIM) INFO = NO_INPUT X IF (NLIM.LT.1) INFO = NO_INPUT X IF (M.LT.3) INFO = NO_INPUT X IF (INFO.NE.NO_ERROR) RETURN C C Check the convergence tolerance and the singular values tolerance. C X IF (TCON.LE.0.0D0) TCON = 0.000001D0 C C Set up the Lanczos tolerances. C X DTMP1 = DEPS() X TMIN = SQRT(DTMP1) X TMAX = 1.0D0 / TMIN X TNRM = SQRT(TMIN) X TSVD = DTMP1 C C Initialize the counters. C X N = 1 X NK = 1 X NKM1 = 1 C C Scale the first pair of Lanczos vectors. C X CSI(1) = 1.0D0 X SIG(1) = 1.0D0 X ST(1) = 1.0D0 X CALL DSCALE (NLEN,_V_(1),_W_(1),SC(1,Q(1)),TOL) C C Check for invariant subspaces (already?). C X INFO = NO_ERROR X IF (CSI(1).EQ.-1.0D0) INFO = INFO + CSI_ZERO X IF (SIG(1).EQ.-1.0D0) INFO = INFO + SIG_ZERO X IF (INFO.NE.NO_ERROR) RETURN C C Initialize the QMR save vector index. C X PIDX = 0 C C Initialize the bound multiplier. C X MULT = 1.0D0 C C Set up WTV(1,1). C X WTV(1,1) = DDOT(NLEN,_V_(1),1,_W_(1),1) X WTV(1,1) = SIG(1) * CSI(1) * WTV(1,1) C C Set up the first element of the right-hand side. C X _OMG_(1) = GETOMG(1) X _RHS_(1) = _OMG_(1) * _S_(1) X MAXOMG = 1.0D0 / _OMG_(1) C C Initialize the norm estimate. C X NORMS(1) = ANORM X NORMS(2) = 0.0D0 C C Compute and save the initial residual norm in R0. C X RESN = 1.0D0 X R0 = DNRM2(NLEN,_V_(1),1) C C Start the trace messages and convergence history. C X NORMS(3) = 1.0D0 X DTMP1 = RESN X IF (VF.NE.0) WRITE (VF,'(I8,I3,4E11.4)') N, N, DTMP1, X $ RESN, NORMS(3), NORMS(1) X IF (TF.NE.0) WRITE (TF,'(I8,I3,4E11.4)') N, N, DTMP1, X $ RESN, NORMS(3), NORMS(1) C C Check for convergence (already?). C X IF (TCON.GE.1.0D0) THEN X INFO = NO_ERROR X RETURN X END IF C C Iterate. C X 10 ONK = NK X ONKM1 = NKM1 C C If we have closed a block, save the working variables, in case we C need to restart. Also, reset the norm estimator. C X IF (N.EQ.NK) THEN X CALL DCOPY (N-NKM1+1,H_NP1,1,HNP1SAV,1) X CALL DCOPY (N-ONKM1+1,H_N(1),1,HNSAV,1) X SAVRHS = _RHS_(N) X NORMS(2) = 0.0D0 X NSAV = N X END IF C C Check whether we have enough room left in the arrays. C X 20 INFO = NO_ERROR X IF (N-NKM1+2.GE.M) INFO = 1 X IF ((INFO.NE.NO_ERROR).AND.(VF.NE.0)) THEN X WRITE (VF,'(A39)') 'Block is maximal, recommending closure.' X END IF C C Compute the matrix vector products. C X CALL AXB (_V_(N), _V_(N+1)) X CALL ATXB (_W_(N), _W_(N+1)) C C Save the block info. C X CALL DCOPY (N-NKM1+1,H_NP1,1,HNP1TMP,1) X CALL DCOPY (N-ONKM1+1,H_N(1),1,HNTMP,1) X TMPRHS = _RHS_(N) C C Do one step of the Lanczos algorithm. C X CALL DLAL (NDIM,NLEN,M,N,NK,NKM1,VW,SC,WK,Q,NORMS,TOL,VF,INFO) C C Set ANORM to the current value of the norm estimate. C X ANORM = NORMS(1) C C Check the info passing variable. C We check whether the DSVDC routine reported errors, whether the C block did not close when it was maximal, or whether an invariant C subspace was found. C X IF (INFO.LT.0) THEN X NLIM = N X RETURN X ELSE IF (INFO.EQ.CSI_ZERO) THEN X NLIM = N X ELSE IF (INFO.EQ.SIG_ZERO) THEN X NLIM = N X ELSE IF (INFO.EQ.ALL_ZERO) THEN X NLIM = N X ELSE IF (INFO.EQ.NORM_UPD) THEN X NSAV = N-1 X SAVRHS = TMPRHS X INFO = NO_CONVG X CALL DCOPY (N-NKM1,HNP1TMP,1,HNP1SAV,1) X CALL DCOPY (N-ONKM1,HNTMP,1,HNSAV,1) X IF (VF.NE.0) WRITE (VF,'(A20)') 'Norm updated.' X ELSE IF (INFO.EQ.NO_CLOSE) THEN X N = NK X IF (VF.NE.0) WRITE (VF,'(A20)') 'Block did not close:' C C Block did not close, do we have another norm estimate? C X IF (NORMS(2).EQ.0.0D0) THEN X IF (VF.NE.0) WRITE (VF,'(A47)') X $ '==> no new norm estimates available (aborting).' X NLIM = N X RETURN X ELSE C C Update the norm --- the block is guaranteed to close now. We then C restart the block from the last update point. C X NORMS(1) = NORMS(2) X IF (VF.NE.0) WRITE (VF,'(A30, E16.8)') X $ '==> updating norm estimate to ', NORMS(1) X N = NSAV X NORMS(2) = 0.0D0 X _RHS_(N) = SAVRHS X CALL DCOPY (N-NKM1+1,HNP1SAV,1,H_NP1,1) X CALL DCOPY (N-ONKM1+1,HNSAV,1,H_N(1),1) X GO TO 20 X END IF X INFO = NO_CONVG X ELSE X INFO = NO_CONVG X END IF C C Get the next scaling factor OMEGA(NP1) and update MAXOMG. C X _OMG_(N) = GETOMG(N) X MAXOMG = MAX(MAXOMG,1.0D0/_OMG_(N)) C C Output the matrix H. C X IF (HF.NE.0) THEN X WRITE (HF,'(I20)') ONKM1 X WRITE (HF,'(I20)') N X WRITE (HF,'(E25.17)') (H_N(I-ONKM1+1),I=ONKM1,N) X END IF C C Compute the starting index in H(:,N-1). C X HBASE = MAX(1,ONKM1-1) C C Multiply the column of H by the OMEGAs and apply all the previous C rotations. C X H_N(1) = _OMG_(HBASE) * H_N(1) C C If we are beyond the first block, then there is fill-in above the C top element in this column of H. This element is saved in ZNK. C X IF (ONKM1.GT.1) THEN X DTMP1 = 0.0D0 X CALL DROT (1,DTMP1,1,H_N(1),1, X $ _COS_(ONKM1),_SIN_(ONKM1)) X _ZNK_(N-1) = DTMP1 X END IF C C Apply the rotations to the rest of the column. C X DO 30 I = ONKM1+1, N-1 X J = I - ONKM1 X H_N(J) = _OMG_(I) * H_N(J) X CALL DROT (1,H_N(J),1,H_N(J+1),1, X $ _COS_(I),_SIN_(I)) X 30 CONTINUE C C H(N) is not reached by the any of the rotations. Multiply it by C its OMEGA and compute the rotation for the column. This will also C apply it. C X J = N - ONKM1 X H_N(J) = _OMG_(N) * H_N(J) X CALL DROTG (H_N(J),H_N(J+1), X $ _COS_(N),_SIN_(N)) C C Apply it to the right-hand side as well. C X _RHS_(N) = 0.0D0 X CALL DROT (1,_RHS_(N-1),1,_RHS_(N),1, X $ _COS_(N),_SIN_(N)) C C Extract the next column of Y_{NK}. C X IF (ONK.GT.ONKM1) THEN X CALL DCOPY (ONK-ONKM1,H_N(1),1,_YNK_(1,N-1),1) X END IF C C Extract the next column of R_{NK}. C X CALL DCOPY (N-ONK,H_N(ONK-ONKM1+1),1,_RNK_(1,N-1),1) C C Set up the work vector for the next step. C X CALL DCOPY (N-NKM1+1,H_NP1,1,H_N(1),1) C C If we haven't closed a block, compute just the new bound. C X IF (NK.EQ.ONK) THEN X DTMP1 = SQRT(FLOAT(N)) * MAXOMG * ABS(_RHS_(N)) / R0 C C If we have closed a block, update the solution. C X ELSE C C Compute the lengths of the blocks. C X LNK = N - ONK X LNKM1 = ONK - ONKM1 X LNKM2 = ONKM1 - ONKM2 C C Zero out P_{NK} R_{NK}. C X DO 40 I = ONK, N-1 X CALL DSCAL (NLEN,0.0D0,_PR_(I),1) X 40 CONTINUE C C Compute the term involving P_{NKM2}. C X IF (ONKM1.GT.1) THEN X DO 50 I = ONK, N-1 X CALL DCOPY (NLEN,_PN_,1,_PR_(I),1) X CALL DSCAL (NLEN,-_ZNK_(I),_PR_(I),1) X 50 CONTINUE X END IF C C Compute the term involving P_{NKM1}. C X IF (ONK.GT.ONKM1) THEN X DO 70 I = ONK, N-1 C C Compute the next column of R_{NKM1}^{-1} * Y_{NK}. C X CALL BCKSUB (M,LNKM1,ONKM1,_RNKALL_, X $ _YNK_(1,I),Q) C C Multiply ( P_{NKM1} R_{NKM1} ) by the new column and add to the C appropriate column of ( P_{NK} R_{NK} ). C X DO 60 J = 1, LNKM1 X CALL DAXPY (NLEN,-_YNK_(J,I), X $ _PR_(ONKM1+J-1),1,_PR_(I),1) X 60 CONTINUE X 70 CONTINUE X END IF C C Now add V_{NK} into ( P_{NK} R_{NK} ). We also use this loop to C copy the right hand side of the least squares problem to a work C vector. C X DO 80 I = ONK, N-1 X CALL DAXPY (NLEN,SIG(I),_V_(I),1, X $ _PR_(I),1) X _YNK_(I-ONK+1,ONK) = _RHS_(I) X 80 CONTINUE C C Compute R_{NK}^{-1} * RHS. C X CALL BCKSUB (M,LNK,ONK,_RNKALL_,_YNK_(1,ONK),Q) C C Update the solution vector. C X DO 90 I = ONK, N-1 X CALL DAXPY (NLEN,_YNK_(I-ONK+1,ONK), X $ _PR_(I),1,_X_,1) X 90 CONTINUE C C Compute the last column of R_{NK}^{-1}. C X CALL DSCAL (M,0.0D0,_YNK_(1,ONK),1) X _YNK_(LNK,ONK) = 1.0D0 X CALL BCKSUB (M,LNK,ONK,_RNKALL_,_YNK_(1,ONK),Q) C C Compute P_N and save it for later use. C X CALL DCOPY (NLEN,_PR_(ONK),1,_PN_,1) X CALL DSCAL (NLEN,_YNK_(1,ONK),_PN_,1) X DO 100 I = ONK+1, N-1 X CALL DAXPY (NLEN,_YNK_(I-ONK+1,ONK), X $ _PR_(I),1,_PN_,1) X 100 CONTINUE C C Compute the residual norm upper bound. C X DTMP1 = SQRT(FLOAT(N)) * MAXOMG * ABS(_RHS_(N)) / R0 C C If the scaled upper bound is within one order of magnitude of the C target convergence norm, compute the true residual norm and check C the scaling factor. C X IF ((TRES.NE.0).OR.(MULT*DTMP1/TCON.LE.10.0D0)) THEN X CALL DCOPY (NLEN,_B_(1),1,TMPV,1) X CALL AXB (_X_,TMPW) X DTMP2 = -1.0D0 X CALL DAXPY (NLEN,DTMP2,TMPW,1,TMPV,1) X RESN = DNRM2(NLEN,TMPV,1) / R0 X IF (DTMP1/RESN.LT.1.0D0) MULT = RESN / DTMP1 X END IF C C Check for convergence. C X IF (RESN.LE.TCON) THEN X INFO = NO_ERROR X NLIM = N X END IF C C Update ONKM2 and the QMR saved vector index. C X PIDX = 1 - PIDX X ONKM2 = ONKM1 X END IF C C Output the trace messages and convergence history. C X IF (VF.NE.0) WRITE (VF,'(I8,I3,4E11.4)') N, N-ONK, DTMP1, X $ RESN, NORMS(3), NORMS(1) X IF (TF.NE.0) WRITE (TF,'(I8,I3,4E11.4)') N, N-ONK, DTMP1, X $ RESN, NORMS(3), NORMS(1) C C Iterate up to NLIM steps. C X IF (N.LT.NLIM) GO TO 10 C C Output the multiplier. C X IF ((VF.NE.0).AND.(MULT.GT.1.0D0)) WRITE (VF,'(A22,E9.2)') X $ 'Res bound multiplier: ', MULT C X RETURN X END C C********************************************************************** C X SUBROUTINE BCKSUB (NDIM,NLEN,NSTART,A,XB,Q) C C Purpose: C Computes XB = inv(A) * XB, where A is upper triangular. C C Parameters: C NDIM = the dimensioned size of A (input). C NLEN = the actual size of A (input). C NSTART = the starting column index for A (input). C A = array containing the matrix of interest starting in the C column NSTART and possibly wrapping around as indicated C by Q (input). C XB = upon entry, the right hand side vector; upon exit, the C solution. XB is not wrapped (input/output). C Q = integer array specifying the actual indices for wrapping C purposes. Q(i) is the true index in A of the ith column C of the matrix of interest (input). C C Noel M. Nachtigal C October 8, 1990 C X INTEGER NDIM, NLEN, NSTART, Q(*) X DOUBLE PRECISION A(NDIM,*), XB(*) C C Local variables. C X INTEGER I, ILAST, ITMP, J X DOUBLE PRECISION DTMP C C Do the elimination; the only trick here is to keep track of the C wrapped columns of A, i.e., A(:,J) is stored in A(:,Q(J)). C X ILAST = NSTART + NLEN - 1 X XB(NLEN) = XB(NLEN) / A(NLEN,Q(ILAST)) X DO 20 I = ILAST-1, NSTART, -1 X DTMP = 0.0D0 X ITMP = I - NSTART + 1 X DO 10 J = I+1, ILAST X DTMP = DTMP + XB(J-NSTART+1) * A(ITMP,Q(J)) X 10 CONTINUE X XB(ITMP) = (XB(ITMP) - DTMP) / A(ITMP,Q(I)) X 20 CONTINUE C X RETURN X END C C********************************************************************** SHAR_EOF chmod 0600 dble/lal/dsyslal.F || echo 'restore of dble/lal/dsyslal.F failed' Wc_c="`wc -c < 'dble/lal/dsyslal.F'`" test 26481 -eq "$Wc_c" || echo 'dble/lal/dsyslal.F: original size 26481, current size' "$Wc_c" fi # ============= dble/lal/makefile ============== if test -f 'dble/lal/makefile' -a X"$1" != X"-c"; then echo 'x - skipping dble/lal/makefile (File already exists)' else echo 'x - extracting dble/lal/makefile (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/lal/makefile' && #********************************************************************** # # Copyright (C) 1991 Roland W. Freund and Noel M. Nachtigal # All rights reserved. # # This code is part of a copyrighted package. For details, see the # file `cpyrit.doc' in the current directory. # # ***************************************************************** # ANY USE OF THIS CODE CONSTITUES ACCEPTANCE OF THE TERMS OF THE # COPYRIGHT NOTICE # ***************************************************************** # #********************************************************************** # # Makefile for the Lanczos subdirectory. # # Files in this directory: # INC = dimblk.inc precon.inc FOR = deig.f deiglal.f dlal.f dsys.f dsysbcg.f dsyslal.f OBJ = dcoeff.o deig.o deiglal.o dlal.o dsys.o dsysbcg.o dsyslal.o getomg.o SRC = dcoeff.f deig.F deiglal.F dlal.F dsys.F dsysbcg.F dsyslal.F getomg.f \ X dlal.inc X # # Include here the skeleton makefile. # include ../skeleton.mak include ../local.mak X # # This is the local help target. # lochelp: X # # Dependencies for files in this directory. # deig.f: deig.F dlal.inc X deiglal.f: deiglal.F dlal.inc X dlal.f: dlal.F dlal.inc X dsys.f: dsys.F dlal.inc X dsysbcg.f: dsysbcg.F dlal.inc X dsyslal.f: dsyslal.F dlal.inc X dcoeff.o: dcoeff.f X deig.o: deig.f dimblk.inc X deiglal.o: deiglal.f X dlal.o: dlal.f X dsys.o: dsys.f dimblk.inc precon.inc X dsysbcg.o: dsysbcg.f X dsyslal.o: dsyslal.f X getomg.o: getomg.f SHAR_EOF chmod 0600 dble/lal/makefile || echo 'restore of dble/lal/makefile failed' Wc_c="`wc -c < 'dble/lal/makefile'`" test 1502 -eq "$Wc_c" || echo 'dble/lal/makefile: original size 1502, current size' "$Wc_c" fi # ============= dble/sup/cpyrit.doc ============== if test ! -d 'dble/sup'; then echo 'x - creating directory dble/sup' mkdir 'dble/sup' fi if test -f 'dble/sup/cpyrit.doc' -a X"$1" != X"-c"; then echo 'x - skipping dble/sup/cpyrit.doc (File already exists)' else echo 'x - extracting dble/sup/cpyrit.doc (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/sup/cpyrit.doc' && C********************************************************************** C C Copyright (C) 1991 Noel M. Nachtigal C All rights reserved. C C This code is provided "as is", without any warranty of any kind, C either expressed or implied, including but not limited to, any C implied warranty of merchantibility or fitness for any purpose. C In no event will any party who distributed the code be liable for C damages or for any claim(s) by any other party, including but not C limited to, any lost profits, lost monies, lost data or data C rendered inaccurate, losses sustained by third parties, or any C other special, incidental or consequential damages arising out of C the use or inability to use the program, even if the possibility C of such damages has been advised against. The entire risk as to C the quality, the performance, and the fitness of the program for C any particular purpose lies with the party using the code. C C No derivative of this code may be used in a commercial package C without the prior explicit written permission of all authors or C their legal proxies. Verbatim copies of this code may be made and C distributed in any medium, provided that this copyright notice C is not removed or altered in any way. No fees may be charged for C distribution of the codes, other than a fee to cover the cost of C the media and a reasonable handling fee. C C********************************************************************** SHAR_EOF chmod 0600 dble/sup/cpyrit.doc || echo 'restore of dble/sup/cpyrit.doc failed' Wc_c="`wc -c < 'dble/sup/cpyrit.doc'`" test 1558 -eq "$Wc_c" || echo 'dble/sup/cpyrit.doc: original size 1558, current size' "$Wc_c" fi # ============= dble/sup/linpack.f ============== if test -f 'dble/sup/linpack.f' -a X"$1" != X"-c"; then echo 'x - skipping dble/sup/linpack.f (File already exists)' else echo 'x - extracting dble/sup/linpack.f (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/sup/linpack.f' && C********************************************************************** C C These are support routines from LINPACK. C C********************************************************************** C X DOUBLE PRECISION FUNCTION DASUM (N,DX,INCX) C C Takes the sum of the absolute values. C C Jack Dongarra, LINPACK C March 11, 1978 C X INTRINSIC ABS, MOD C X INTEGER INCX, N X DOUBLE PRECISION DX(*) C C Local variables. C X INTEGER I, M, MP1, NINCX X DOUBLE PRECISION DTEMP C X DASUM = 0.0 X DTEMP = 0.0 X IF (N.LE.0) RETURN X IF (INCX.NE.1) GO TO 50 C C Code for increment equal to 1. C X M = MOD(N,8) X IF (M.EQ.0) GO TO 20 X DO 10 I = 1, M X DTEMP = DTEMP + ABS(DX(I)) X 10 CONTINUE X IF (N.LT.8) GO TO 40 X 20 MP1 = M + 1 X DO 30 I = MP1, N, 8 X DTEMP = DTEMP X $ + ABS(DX(I)) X $ + ABS(DX(I+1)) X $ + ABS(DX(I+2)) X $ + ABS(DX(I+3)) X $ + ABS(DX(I+4)) X $ + ABS(DX(I+5)) X $ + ABS(DX(I+6)) X $ + ABS(DX(I+7)) X 30 CONTINUE X 40 DASUM = DTEMP X RETURN C C Code for increment not equal to 1. C X 50 NINCX = N * INCX X DO 60 I = 1, NINCX, INCX X DTEMP = DTEMP + ABS(DX(I)) X 60 CONTINUE X DASUM = DTEMP C X RETURN X END C C********************************************************************** C X SUBROUTINE DAXPY (N,DA,DX,INCX,DY,INCY) C C constant times a vector plus a vector. C uses unrolled loops for increments equal to one. C jack dongarra, linpack, 3/11/78. C X DOUBLE PRECISION DX(1),DY(1),DA X INTEGER I,INCX,INCY,IX,IY,M,MP1,N C 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 C C code for unequal increments or equal increments C not equal to 1 C 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 C C code for both increments equal to 1 C C C clean-up loop C 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 C********************************************************************** C X SUBROUTINE DCOPY (N,DX,INCX,DY,INCY) C C copies a vector, x, to a vector, y. C uses unrolled loops for increments equal to one. C jack dongarra, linpack, 3/11/78. C X DOUBLE PRECISION DX(1),DY(1) X INTEGER I,INCX,INCY,IX,IY,M,MP1,N C X IF (N.LE.0) RETURN X IF (INCX.EQ.1.AND.INCY.EQ.1) GO TO 20 C C code for unequal increments or equal increments C not equal to 1 C 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 C C code for both increments equal to 1 C C C clean-up loop C 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 C********************************************************************** C X DOUBLE PRECISION FUNCTION DDOT (N,DX,INCX,DY,INCY) C C forms the dot product of two vectors. C uses unrolled loops for increments equal to one. C jack dongarra, linpack, 3/11/78. C X DOUBLE PRECISION DX(1),DY(1),DTEMP X INTEGER I,INCX,INCY,IX,IY,M,MP1,N C 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 C C code for unequal increments or equal increments C not equal to 1 C 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 C C code for both increments equal to 1 C C C clean-up loop C 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)+DX(I+2)*DY(I+2)+DX(I+3) X $ *DY(I+3)+DX(I+4)*DY(I+4) X 50 CONTINUE X 60 DDOT=DTEMP X RETURN X END C********************************************************************** C X DOUBLE PRECISION FUNCTION DNRM2 (N,DX,INCX) X INTEGER NEXT X DOUBLE PRECISION DX(1),CUTLO,CUTHI,HITEST,SUM,XMAX,ZERO,ONE X DATA ZERO,ONE/0.0D0,1.0D0/ C C euclidean norm of the n-vector stored in dx() with storage C increment incx . C if n .le. 0 return with result = 0. C if n .ge. 1 then incx must be .ge. 1 C C c.l.lawson, 1978 jan 08 C C four phase method using two built-in constants that are C hopefully applicable to all machines. C cutlo = maximum of dsqrt(u/eps) over all known machines. C cuthi = minimum of dsqrt(v) over all known machines. C where C eps = smallest no. such that eps + 1. .gt. 1. C u = smallest positive no. (underflow limit) C v = largest no. (overflow limit) C C brief outline of algorithm.. C C phase 1 scans zero components. C move to phase 2 when a component is nonzero and .le. cutlo C move to phase 3 when a component is .gt. cutlo C move to phase 4 when a component is .ge. cuthi/m C where m = n for x() real and m = 2*n for complex. C C values for cutlo and cuthi.. C from the environmental parameters listed in the imsl converter C document the limiting values are as follows.. C cutlo, s.p. u/eps = 2**(-102) for honeywell. close seconds are C univac and dec at 2**(-103) C thus cutlo = 2**(-51) = 4.44089e-16 C cuthi, s.p. v = 2**127 for univac, honeywell, and dec. C thus cuthi = 2**(63.5) = 1.30438e19 C cutlo, d.p. u/eps = 2**(-67) for honeywell and dec. C thus cutlo = 2**(-33.5) = 8.23181d-11 C cuthi, d.p. same as s.p. cuthi = 1.30438d19 C data cutlo, cuthi / 8.232d-11, 1.304d19 / C data cutlo, cuthi / 4.441e-16, 1.304e19 / X DATA CUTLO,CUTHI/8.232D-11,1.304D19/ C X INTEGER I,INCX,J,N,NN C X IF (N.GT.0) GO TO 10 X DNRM2=ZERO X GO TO 140 C X 10 ASSIGN 30 TO NEXT X SUM=ZERO X NN=N*INCX C begin main loop X I=1 X 20 GO TO NEXT, (30,40,70,80) X 30 IF (DABS(DX(I)).GT.CUTLO) GO TO 110 X ASSIGN 40 TO NEXT X XMAX=ZERO C C phase 1. sum is zero C X 40 IF (DX(I).EQ.ZERO) GO TO 130 X IF (DABS(DX(I)).GT.CUTLO) GO TO 110 C C prepare for phase 2. X ASSIGN 70 TO NEXT X GO TO 60 C C prepare for phase 4. C X 50 I=J X ASSIGN 80 TO NEXT X SUM=(SUM/DX(I))/DX(I) X 60 XMAX=DABS(DX(I)) X GO TO 90 C C phase 2. sum is small. C scale to avoid destructive underflow. C X 70 IF (DABS(DX(I)).GT.CUTLO) GO TO 100 C C common code for phases 2 and 4. C in phase 4 sum is large. scale to avoid overflow. C X 80 IF (DABS(DX(I)).LE.XMAX) GO TO 90 X SUM=ONE+SUM*(XMAX/DX(I))**2 X XMAX=DABS(DX(I)) X GO TO 130 C X 90 SUM=SUM+(DX(I)/XMAX)**2 X GO TO 130 C C C prepare for phase 3. C X 100 SUM=(SUM*XMAX)*XMAX C C C for real or d.p. set hitest = cuthi/n C for complex set hitest = cuthi/(2*n) C X 110 HITEST=CUTHI/FLOAT(N) C C phase 3. sum is mid-range. no scaling. C X DO 120 J=I,NN,INCX X IF (DABS(DX(J)).GE.HITEST) GO TO 50 X 120 SUM=SUM+DX(J)**2 X DNRM2=DSQRT(SUM) X GO TO 140 C X 130 I=I+INCX X IF (I.LE.NN) GO TO 20 C C end of main loop. C C compute square root and adjust for scaling. C X DNRM2=XMAX*DSQRT(SUM) X 140 RETURN X END C C********************************************************************** C X subroutine dqrdc(x,ldx,n,p,qraux,jpvt,work,job) X integer ldx,n,p,job X integer jpvt(1) X double precision x(ldx,1),qraux(1),work(1) c c dqrdc uses householder transformations to compute the qr c factorization of an n by p matrix x. column pivoting c based on the 2-norms of the reduced columns may be c performed at the users option. c c on entry c c x double precision(ldx,p), where ldx .ge. n. c x contains the matrix whose decomposition is to be c computed. c c ldx integer. c ldx is the leading dimension of the array x. c c n integer. c n is the number of rows of the matrix x. c c p integer. c p is the number of columns of the matrix x. c c jpvt integer(p). c jpvt contains integers that control the selection c of the pivot columns. the k-th column x(k) of x c is placed in one of three classes according to the c value of jpvt(k). c c if jpvt(k) .gt. 0, then x(k) is an initial c column. c c if jpvt(k) .eq. 0, then x(k) is a free column. c c if jpvt(k) .lt. 0, then x(k) is a final column. c c before the decomposition is computed, initial columns c are moved to the beginning of the array x and final c columns to the end. both initial and final columns c are frozen in place during the computation and only c free columns are moved. at the k-th stage of the c reduction, if x(k) is occupied by a free column c it is interchanged with the free column of largest c reduced norm. jpvt is not referenced if c job .eq. 0. c c work double precision(p). c work is a work array. work is not referenced if c job .eq. 0. c c job integer. c job is an integer that initiates column pivoting. c if job .eq. 0, no pivoting is done. c if job .ne. 0, pivoting is done. c c on return c c x x contains in its upper triangle the upper c triangular matrix r of the qr factorization. c below its diagonal x contains information from c which the orthogonal part of the decomposition c can be recovered. note that if pivoting has c been requested, the decomposition is not that c of the original matrix x but that of x c with its columns permuted as described by jpvt. c c qraux double precision(p). c qraux contains further information required to recover c the orthogonal part of the decomposition. c c jpvt jpvt(k) contains the index of the column of the c original matrix that has been interchanged into c the k-th column, if pivoting was requested. c c linpack. this version dated 08/14/78 . c g.w. stewart, university of maryland, argonne national lab. c c dqrdc uses the following functions and subprograms. c c blas daxpy,ddot,dscal,dswap,dnrm2 c fortran dabs,dmax1,min0,dsqrt c c internal variables c X integer j,jj,jp,l,lp1,lup,maxj,pl,pu X double precision maxnrm,dnrm2,tt X double precision ddot,nrmxl,t X logical negj,swapj c c X pl = 1 X pu = 0 X if (job .eq. 0) go to 60 c c pivoting has been requested. rearrange the columns c according to jpvt. c X do 20 j = 1, p X swapj = jpvt(j) .gt. 0 X negj = jpvt(j) .lt. 0 X jpvt(j) = j X if (negj) jpvt(j) = -j X if (.not.swapj) go to 10 X if (j .ne. pl) call dswap(n,x(1,pl),1,x(1,j),1) X jpvt(j) = jpvt(pl) X jpvt(pl) = j X pl = pl + 1 X 10 continue X 20 continue X pu = p X do 50 jj = 1, p X j = p - jj + 1 X if (jpvt(j) .ge. 0) go to 40 X jpvt(j) = -jpvt(j) X if (j .eq. pu) go to 30 X call dswap(n,x(1,pu),1,x(1,j),1) X jp = jpvt(pu) X jpvt(pu) = jpvt(j) X jpvt(j) = jp X 30 continue X pu = pu - 1 X 40 continue X 50 continue X 60 continue c c compute the norms of the free columns. c X if (pu .lt. pl) go to 80 X do 70 j = pl, pu X qraux(j) = dnrm2(n,x(1,j),1) X work(j) = qraux(j) X 70 continue X 80 continue c c perform the householder reduction of x. c X lup = min0(n,p) X do 200 l = 1, lup X if (l .lt. pl .or. l .ge. pu) go to 120 c c locate the column of largest norm and bring it c into the pivot position. c X maxnrm = 0.0d0 X maxj = l X do 100 j = l, pu X if (qraux(j) .le. maxnrm) go to 90 X maxnrm = qraux(j) X maxj = j X 90 continue X 100 continue X if (maxj .eq. l) go to 110 X call dswap(n,x(1,l),1,x(1,maxj),1) X qraux(maxj) = qraux(l) X work(maxj) = work(l) X jp = jpvt(maxj) X jpvt(maxj) = jpvt(l) X jpvt(l) = jp X 110 continue X 120 continue X qraux(l) = 0.0d0 X if (l .eq. n) go to 190 c c compute the householder transformation for column l. c X nrmxl = dnrm2(n-l+1,x(l,l),1) X if (nrmxl .eq. 0.0d0) go to 180 X if (x(l,l) .ne. 0.0d0) nrmxl = dsign(nrmxl,x(l,l)) X call dscal(n-l+1,1.0d0/nrmxl,x(l,l),1) X x(l,l) = 1.0d0 + x(l,l) c c apply the transformation to the remaining columns, c updating the norms. c X lp1 = l + 1 X if (p .lt. lp1) go to 170 X do 160 j = lp1, p X t = -ddot(n-l+1,x(l,l),1,x(l,j),1)/x(l,l) X call daxpy(n-l+1,t,x(l,l),1,x(l,j),1) X if (j .lt. pl .or. j .gt. pu) go to 150 X if (qraux(j) .eq. 0.0d0) go to 150 X tt = 1.0d0 - (dabs(x(l,j))/qraux(j))**2 X tt = dmax1(tt,0.0d0) X t = tt X tt = 1.0d0 + 0.05d0*tt*(qraux(j)/work(j))**2 X if (tt .eq. 1.0d0) go to 130 X qraux(j) = qraux(j)*dsqrt(t) X go to 140 X 130 continue X qraux(j) = dnrm2(n-l,x(l+1,j),1) X work(j) = qraux(j) X 140 continue X 150 continue X 160 continue X 170 continue c c save the transformation. c X qraux(l) = x(l,l) X x(l,l) = -nrmxl X 180 continue X 190 continue X 200 continue X return X end C C********************************************************************** C X subroutine dqrsl(x,ldx,n,k,qraux,y,qy,qty,b,rsd,xb,job,info) X integer ldx,n,k,job,info X double precision x(ldx,1),qraux(1),y(1),qy(1),qty(1),b(1),rsd(1), X * xb(1) c c dqrsl applies the output of dqrdc to compute coordinate c transformations, projections, and least squares solutions. c for k .le. min(n,p), let xk be the matrix c c xk = (x(jpvt(1)),x(jpvt(2)), ... ,x(jpvt(k))) c c formed from columnns jpvt(1), ... ,jpvt(k) of the original c n x p matrix x that was input to dqrdc (if no pivoting was c done, xk consists of the first k columns of x in their c original order). dqrdc produces a factored orthogonal matrix q c and an upper triangular matrix r such that c c xk = q * (r) c (0) c c this information is contained in coded form in the arrays c x and qraux. c c on entry c c x double precision(ldx,p). c x contains the output of dqrdc. c c ldx integer. c ldx is the leading dimension of the array x. c c n integer. c n is the number of rows of the matrix xk. it must c have the same value as n in dqrdc. c c k integer. c k is the number of columns of the matrix xk. k c must nnot be greater than min(n,p), where p is the c same as in the calling sequence to dqrdc. c c qraux double precision(p). c qraux contains the auxiliary output from dqrdc. c c y double precision(n) c y contains an n-vector that is to be manipulated c by dqrsl. c c job integer. c job specifies what is to be computed. job has c the decimal expansion abcde, with the following c meaning. c c if a.ne.0, compute qy. c if b,c,d, or e .ne. 0, compute qty. c if c.ne.0, compute b. c if d.ne.0, compute rsd. c if e.ne.0, compute xb. c c note that a request to compute b, rsd, or xb c automatically triggers the computation of qty, for c which an array must be provided in the calling c sequence. c c on return c c qy double precision(n). c qy conntains q*y, if its computation has been c requested. c c qty double precision(n). c qty contains trans(q)*y, if its computation has c been requested. here trans(q) is the c transpose of the matrix q. c c b double precision(k) c b contains the solution of the least squares problem c c minimize norm2(y - xk*b), c c if its computation has been requested. (note that c if pivoting was requested in dqrdc, the j-th c component of b will be associated with column jpvt(j) c of the original matrix x that was input into dqrdc.) c c rsd double precision(n). c rsd contains the least squares residual y - xk*b, c if its computation has been requested. rsd is c also the orthogonal projection of y onto the c orthogonal complement of the column space of xk. c c xb double precision(n). c xb contains the least squares approximation xk*b, c if its computation has been requested. xb is also c the orthogonal projection of y onto the column space c of x. c c info integer. c info is zero unless the computation of b has c been requested and r is exactly singular. in c this case, info is the index of the first zero c diagonal element of r and b is left unaltered. c c the parameters qy, qty, b, rsd, and xb are not referenced c if their computation is not requested and in this case c can be replaced by dummy variables in the calling program. c to save storage, the user may in some cases use the same c array for different parameters in the calling sequence. a c frequently occuring example is when one wishes to compute c any of b, rsd, or xb and does not need y or qty. in this c case one may identify y, qty, and one of b, rsd, or xb, while c providing separate arrays for anything else that is to be c computed. thus the calling sequence c c call dqrsl(x,ldx,n,k,qraux,y,dum,y,b,y,dum,110,info) c c will result in the computation of b and rsd, with rsd c overwriting y. more generally, each item in the following c list contains groups of permissible identifications for c a single callinng sequence. c c 1. (y,qty,b) (rsd) (xb) (qy) c c 2. (y,qty,rsd) (b) (xb) (qy) c c 3. (y,qty,xb) (b) (rsd) (qy) c c 4. (y,qy) (qty,b) (rsd) (xb) c c 5. (y,qy) (qty,rsd) (b) (xb) c c 6. (y,qy) (qty,xb) (b) (rsd) c c in any group the value returned in the array allocated to c the group corresponds to the last member of the group. c c linpack. this version dated 08/14/78 . c g.w. stewart, university of maryland, argonne national lab. c c dqrsl uses the following functions and subprograms. c c blas daxpy,dcopy,ddot c fortran dabs,min0,mod c c internal variables c X integer i,j,jj,ju,kp1 X double precision ddot,t,temp X logical cb,cqy,cqty,cr,cxb c c c set info flag. c X info = 0 c c determine what is to be computed. c X cqy = job/10000 .ne. 0 X cqty = mod(job,10000) .ne. 0 X cb = mod(job,1000)/100 .ne. 0 X cr = mod(job,100)/10 .ne. 0 X cxb = mod(job,10) .ne. 0 X ju = min0(k,n-1) c c special action when n=1. c X if (ju .ne. 0) go to 40 X if (cqy) qy(1) = y(1) X if (cqty) qty(1) = y(1) X if (cxb) xb(1) = y(1) X if (.not.cb) go to 30 X if (x(1,1) .ne. 0.0d0) go to 10 X info = 1 X go to 20 X 10 continue X b(1) = y(1)/x(1,1) X 20 continue X 30 continue X if (cr) rsd(1) = 0.0d0 X go to 250 X 40 continue c c set up to compute qy or qty. c X if (cqy) call dcopy(n,y,1,qy,1) X if (cqty) call dcopy(n,y,1,qty,1) X if (.not.cqy) go to 70 c c compute qy. c X do 60 jj = 1, ju X j = ju - jj + 1 X if (qraux(j) .eq. 0.0d0) go to 50 X temp = x(j,j) X x(j,j) = qraux(j) X t = -ddot(n-j+1,x(j,j),1,qy(j),1)/x(j,j) X call daxpy(n-j+1,t,x(j,j),1,qy(j),1) X x(j,j) = temp X 50 continue X 60 continue X 70 continue X if (.not.cqty) go to 100 c c compute trans(q)*y. c X do 90 j = 1, ju X if (qraux(j) .eq. 0.0d0) go to 80 X temp = x(j,j) X x(j,j) = qraux(j) X t = -ddot(n-j+1,x(j,j),1,qty(j),1)/x(j,j) X call daxpy(n-j+1,t,x(j,j),1,qty(j),1) X x(j,j) = temp X 80 continue X 90 continue X 100 continue c c set up to compute b, rsd, or xb. c X if (cb) call dcopy(k,qty,1,b,1) X kp1 = k + 1 X if (cxb) call dcopy(k,qty,1,xb,1) X if (cr .and. k .lt. n) call dcopy(n-k,qty(kp1),1,rsd(kp1),1) X if (.not.cxb .or. kp1 .gt. n) go to 120 X do 110 i = kp1, n X xb(i) = 0.0d0 X 110 continue X 120 continue X if (.not.cr) go to 140 X do 130 i = 1, k X rsd(i) = 0.0d0 X 130 continue X 140 continue X if (.not.cb) go to 190 c c compute b. c X do 170 jj = 1, k X j = k - jj + 1 X if (x(j,j) .ne. 0.0d0) go to 150 X info = j c ......exit X go to 180 X 150 continue X b(j) = b(j)/x(j,j) X if (j .eq. 1) go to 160 X t = -b(j) X call daxpy(j-1,t,x(1,j),1,b,1) X 160 continue X 170 continue X 180 continue X 190 continue X if (.not.cr .and. .not.cxb) go to 240 c c compute rsd or xb as required. c X do 230 jj = 1, ju X j = ju - jj + 1 X if (qraux(j) .eq. 0.0d0) go to 220 X temp = x(j,j) X x(j,j) = qraux(j) X if (.not.cr) go to 200 X t = -ddot(n-j+1,x(j,j),1,rsd(j),1)/x(j,j) X call daxpy(n-j+1,t,x(j,j),1,rsd(j),1) X 200 continue X if (.not.cxb) go to 210 X t = -ddot(n-j+1,x(j,j),1,xb(j),1)/x(j,j) X call daxpy(n-j+1,t,x(j,j),1,xb(j),1) X 210 continue X x(j,j) = temp X 220 continue X 230 continue X 240 continue X 250 continue X return X end C C********************************************************************** C X SUBROUTINE DROT (N,DX,INCX,DY,INCY,C,S) C C applies a plane rotation. C jack dongarra, linpack, 3/11/78. C X DOUBLE PRECISION DX(1),DY(1),DTEMP,C,S X INTEGER I,INCX,INCY,IX,IY,N C X IF (N.LE.0) RETURN X IF (INCX.EQ.1.AND.INCY.EQ.1) GO TO 20 C C code for unequal increments or equal increments not equal C to 1 C 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=C*DX(IX)+S*DY(IY) X DY(IY)=C*DY(IY)-S*DX(IX) X DX(IX)=DTEMP X IX=IX+INCX X IY=IY+INCY X 10 CONTINUE X RETURN C C code for both increments equal to 1 C X 20 DO 30 I=1,N X DTEMP=C*DX(I)+S*DY(I) X DY(I)=C*DY(I)-S*DX(I) X DX(I)=DTEMP X 30 CONTINUE X RETURN X END C********************************************************************** C X SUBROUTINE DROTG (DA,DB,C,S) C C construct givens plane rotation. C jack dongarra, linpack, 3/11/78. C X DOUBLE PRECISION DA,DB,C,S,ROE,SCALE,R,Z C X ROE=DB X IF (DABS(DA).GT.DABS(DB)) ROE=DA X SCALE=DABS(DA)+DABS(DB) X IF (SCALE.NE.0.0D0) GO TO 10 X C=1.0D0 X S=0.0D0 X R=0.0D0 X GO TO 20 X 10 R=SCALE*DSQRT((DA/SCALE)**2+(DB/SCALE)**2) X R=DSIGN(1.0D0,ROE)*R X C=DA/R X S=DB/R X 20 Z=1.0D0 X IF (DABS(DA).GT.DABS(DB)) Z=S X IF (DABS(DB).GE.DABS(DA).AND.C.NE.0.0D0) Z=1.0D0/C X DA=R X DB=Z X RETURN X END C********************************************************************** C X SUBROUTINE DSCAL (N,DA,DX,INCX) C C scales a vector by a constant. C uses unrolled loops for increment equal to one. C jack dongarra, linpack, 3/11/78. C X DOUBLE PRECISION DA,DX(1) X INTEGER I,INCX,M,MP1,N,NINCX C X IF (N.LE.0) RETURN X IF (INCX.EQ.1) GO TO 20 C C code for increment not equal to 1 C X NINCX=N*INCX X DO 10 I=1,NINCX,INCX X DX(I)=DA*DX(I) X 10 CONTINUE X RETURN C C code for increment equal to 1 C C C clean-up loop C 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 C********************************************************************** C X SUBROUTINE DSVDC (X,LDX,N,P,S,E,U,LDU,V,LDV,WORK,JOB,INFO) X INTEGER LDX,N,P,LDU,LDV,JOB,INFO X DOUBLE PRECISION X(LDX,1),S(1),E(1),U(LDU,1),V(LDV,1),WORK(1) C C C DSVDC IS A SUBROUTINE TO REDUCE A DOUBLE PRECISION NXP MATRIX X C BY ORTHOGONAL TRANSFORMATIONS U AND V TO DIAGONAL FORM. THE C DIAGONAL ELEMENTS S(I) ARE THE SINGULAR VALUES OF X. THE C COLUMNS OF U ARE THE CORRESPONDING LEFT SINGULAR VECTORS, C AND THE COLUMNS OF V THE RIGHT SINGULAR VECTORS. C C ON ENTRY C C X DOUBLE PRECISION(LDX,P), WHERE LDX.GE.N. C X CONTAINS THE MATRIX WHOSE SINGULAR VALUE C DECOMPOSITION IS TO BE COMPUTED. X IS C DESTROYED BY DSVDC. C C LDX INTEGER. C LDX IS THE LEADING DIMENSION OF THE ARRAY X. C C N INTEGER. C N IS THE NUMBER OF ROWS OF THE MATRIX X. C C P INTEGER. C P IS THE NUMBER OF COLUMNS OF THE MATRIX X. C C LDU INTEGER. C LDU IS THE LEADING DIMENSION OF THE ARRAY U. C (SEE BELOW). C C LDV INTEGER. C LDV IS THE LEADING DIMENSION OF THE ARRAY V. C (SEE BELOW). C C WORK DOUBLE PRECISION(N). C WORK IS A SCRATCH ARRAY. C C JOB INTEGER. C JOB CONTROLS THE COMPUTATION OF THE SINGULAR C VECTORS. IT HAS THE DECIMAL EXPANSION AB C WITH THE FOLLOWING MEANING C C A.EQ.0 DO NOT COMPUTE THE LEFT SINGULAR C VECTORS. C A.EQ.1 RETURN THE N LEFT SINGULAR VECTORS C IN U. C A.GE.2 RETURN THE FIRST MIN(N,P) SINGULAR C VECTORS IN U. C B.EQ.0 DO NOT COMPUTE THE RIGHT SINGULAR C VECTORS. C B.EQ.1 RETURN THE RIGHT SINGULAR VECTORS C IN V. C C ON RETURN C C S DOUBLE PRECISION(MM), WHERE MM=MIN(N+1,P). C THE FIRST MIN(N,P) ENTRIES OF S CONTAIN THE C SINGULAR VALUES OF X ARRANGED IN DESCENDING C ORDER OF MAGNITUDE. C C E DOUBLE PRECISION(P), C E ORDINARILY CONTAINS ZEROS. HOWEVER SEE THE C DISCUSSION OF INFO FOR EXCEPTIONS. C C U DOUBLE PRECISION(LDU,K), WHERE LDU.GE.N. IF C JOBA.EQ.1 THEN K.EQ.N, IF JOBA.GE.2 C THEN K.EQ.MIN(N,P). C U CONTAINS THE MATRIX OF LEFT SINGULAR VECTORS. C U IS NOT REFERENCED IF JOBA.EQ.0. IF N.LE.P C OR IF JOBA.EQ.2, THEN U MAY BE IDENTIFIED WITH X C IN THE SUBROUTINE CALL. C C V DOUBLE PRECISION(LDV,P), WHERE LDV.GE.P. C V CONTAINS THE MATRIX OF RIGHT SINGULAR VECTORS. C V IS NOT REFERENCED IF JOB.EQ.0. IF P.LE.N, C THEN V MAY BE IDENTIFIED WITH X IN THE C SUBROUTINE CALL. C C INFO INTEGER. C THE SINGULAR VALUES (AND THEIR CORRESPONDING C SINGULAR VECTORS) S(INFO+1),S(INFO+2),...,S(M) C ARE CORRECT (HERE M=MIN(N,P)). THUS IF C INFO.EQ.0, ALL THE SINGULAR VALUES AND THEIR C VECTORS ARE CORRECT. IN ANY EVENT, THE MATRIX C B = TRANS(U)*X*V IS THE BIDIAGONAL MATRIX C WITH THE ELEMENTS OF S ON ITS DIAGONAL AND THE C ELEMENTS OF E ON ITS SUPER-DIAGONAL (TRANS(U) C IS THE TRANSPOSE OF U). THUS THE SINGULAR C VALUES OF X AND B ARE THE SAME. C C LINPACK. THIS VERSION DATED 08/14/78 . C CORRECTION MADE TO SHIFT 2/84. C G.W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB. C C DSVDC USES THE FOLLOWING FUNCTIONS AND SUBPROGRAMS. C C EXTERNAL DROT C BLAS DAXPY,DDOT,DSCAL,DSWAP,DNRM2,DROTG C FORTRAN DABS,DMAX1,MAX0,MIN0,MOD,DSQRT C C INTERNAL VARIABLES C X INTEGER I,ITER,J,JOBU,K,KASE,KK,L,LL,LLS,LM1,LP1,LS,LU,M,MAXIT,MM, X $MM1,MP1,NCT,NCTP1,NCU,NRT,NRTP1 X DOUBLE PRECISION DDOT,T X DOUBLE PRECISION B,C,CS,EL,EMM1,F,G,DNRM2,SCALE,SHIFT,SL,SM,SN, X $SMM1,T1,TEST,ZTEST X LOGICAL WANTU,WANTV C C SET THE MAXIMUM NUMBER OF ITERATIONS. C X MAXIT=30 C C DETERMINE WHAT IS TO BE COMPUTED. C X WANTU=.FALSE. X WANTV=.FALSE. X JOBU=MOD(JOB,100)/10 X NCU=N X IF (JOBU.GT.1) NCU=MIN0(N,P) X IF (JOBU.NE.0) WANTU=.TRUE. X IF (MOD(JOB,10).NE.0) WANTV=.TRUE. C C REDUCE X TO BIDIAGONAL FORM, STORING THE DIAGONAL ELEMENTS C IN S AND THE SUPER-DIAGONAL ELEMENTS IN E. C X INFO=0 X NCT=MIN0(N-1,P) X NRT=MAX0(0,MIN0(P-2,N)) X LU=MAX0(NCT,NRT) X IF (LU.LT.1) GO TO 150 X DO 140 L=1,LU X LP1=L+1 X IF (L.GT.NCT) GO TO 20 C C COMPUTE THE TRANSFORMATION FOR THE L-TH COLUMN AND C PLACE THE L-TH DIAGONAL IN S(L). C X S(L)=DNRM2(N-L+1,X(L,L),1) X IF (S(L).EQ.0.0D0) GO TO 10 X IF (X(L,L).NE.0.0D0) S(L)=DSIGN(S(L),X(L,L)) X CALL DSCAL (N-L+1,1.0D0/S(L),X(L,L),1) X X(L,L)=1.0D0+X(L,L) X 10 S(L)=-S(L) X 20 IF (P.LT.LP1) GO TO 50 X DO 40 J=LP1,P X IF (L.GT.NCT) GO TO 30 X IF (S(L).EQ.0.0D0) GO TO 30 C C APPLY THE TRANSFORMATION. C X T=-DDOT(N-L+1,X(L,L),1,X(L,J),1)/X(L,L) X CALL DAXPY (N-L+1,T,X(L,L),1,X(L,J),1) C C PLACE THE L-TH ROW OF X INTO E FOR THE C SUBSEQUENT CALCULATION OF THE ROW TRANSFORMATION. C X 30 E(J)=X(L,J) X 40 CONTINUE X 50 IF (.NOT.WANTU.OR.L.GT.NCT) GO TO 70 C C PLACE THE TRANSFORMATION IN U FOR SUBSEQUENT BACK C MULTIPLICATION. C X DO 60 I=L,N X U(I,L)=X(I,L) X 60 CONTINUE X 70 IF (L.GT.NRT) GO TO 140 C C COMPUTE THE L-TH ROW TRANSFORMATION AND PLACE THE C L-TH SUPER-DIAGONAL IN E(L). C X E(L)=DNRM2(P-L,E(LP1),1) X IF (E(L).EQ.0.0D0) GO TO 80 X IF (E(LP1).NE.0.0D0) E(L)=DSIGN(E(L),E(LP1)) X CALL DSCAL (P-L,1.0D0/E(L),E(LP1),1) X E(LP1)=1.0D0+E(LP1) X 80 E(L)=-E(L) X IF (LP1.GT.N.OR.E(L).EQ.0.0D0) GO TO 120 C C APPLY THE TRANSFORMATION. C X DO 90 I=LP1,N X WORK(I)=0.0D0 X 90 CONTINUE X DO 100 J=LP1,P X CALL DAXPY (N-L,E(J),X(LP1,J),1,WORK(LP1),1) X 100 CONTINUE X DO 110 J=LP1,P X CALL DAXPY (N-L,-E(J)/E(LP1),WORK(LP1),1,X(LP1,J),1) X 110 CONTINUE X 120 IF (.NOT.WANTV) GO TO 140 C C PLACE THE TRANSFORMATION IN V FOR SUBSEQUENT C BACK MULTIPLICATION. C X DO 130 I=LP1,P X V(I,L)=E(I) X 130 CONTINUE X 140 CONTINUE C C SET UP THE FINAL BIDIAGONAL MATRIX OR ORDER M. C X 150 M=MIN0(P,N+1) X NCTP1=NCT+1 X NRTP1=NRT+1 X IF (NCT.LT.P) S(NCTP1)=X(NCTP1,NCTP1) X IF (N.LT.M) S(M)=0.0D0 X IF (NRTP1.LT.M) E(NRTP1)=X(NRTP1,M) X E(M)=0.0D0 C C IF REQUIRED, GENERATE U. C X IF (.NOT.WANTU) GO TO 250 X IF (NCU.LT.NCTP1) GO TO 180 X DO 170 J=NCTP1,NCU X DO 160 I=1,N X U(I,J)=0.0D0 X 160 CONTINUE X U(J,J)=1.0D0 X 170 CONTINUE X 180 IF (NCT.LT.1) GO TO 250 X DO 240 LL=1,NCT X L=NCT-LL+1 X IF (S(L).EQ.0.0D0) GO TO 220 X LP1=L+1 X IF (NCU.LT.LP1) GO TO 200 X DO 190 J=LP1,NCU X T=-DDOT(N-L+1,U(L,L),1,U(L,J),1)/U(L,L) X CALL DAXPY (N-L+1,T,U(L,L),1,U(L,J),1) X 190 CONTINUE X 200 CALL DSCAL (N-L+1,-1.0D0,U(L,L),1) X U(L,L)=1.0D0+U(L,L) X LM1=L-1 X IF (LM1.LT.1) GO TO 240 X DO 210 I=1,LM1 X U(I,L)=0.0D0 X 210 CONTINUE X GO TO 240 X 220 DO 230 I=1,N X U(I,L)=0.0D0 X 230 CONTINUE X U(L,L)=1.0D0 X 240 CONTINUE C C IF IT IS REQUIRED, GENERATE V. C X 250 IF (.NOT.WANTV) GO TO 300 X DO 290 LL=1,P X L=P-LL+1 X LP1=L+1 X IF (L.GT.NRT) GO TO 270 X IF (E(L).EQ.0.0D0) GO TO 270 X DO 260 J=LP1,P X T=-DDOT(P-L,V(LP1,L),1,V(LP1,J),1)/V(LP1,L) X CALL DAXPY (P-L,T,V(LP1,L),1,V(LP1,J),1) X 260 CONTINUE X 270 DO 280 I=1,P X V(I,L)=0.0D0 X 280 CONTINUE X V(L,L)=1.0D0 X 290 CONTINUE C C MAIN ITERATION LOOP FOR THE SINGULAR VALUES. C X 300 MM=M X ITER=0 C C QUIT IF ALL THE SINGULAR VALUES HAVE BEEN FOUND. C C ...EXIT X 310 IF (M.EQ.0) GO TO 520 C C IF TOO MANY ITERATIONS HAVE BEEN PERFORMED, SET C FLAG AND RETURN. C X IF (ITER.LT.MAXIT) GO TO 320 X INFO=M C ......EXIT X GO TO 520 C C THIS SECTION OF THE PROGRAM INSPECTS FOR C NEGLIGIBLE ELEMENTS IN THE S AND E ARRAYS. ON C COMPLETION THE VARIABLES KASE AND L ARE SET AS FOLLOWS. C C KASE = 1 IF S(M) AND E(L-1) ARE NEGLIGIBLE AND L.LT.M C KASE = 2 IF S(L) IS NEGLIGIBLE AND L.LT.M C KASE = 3 IF E(L-1) IS NEGLIGIBLE, L.LT.M, AND C S(L), ..., S(M) ARE NOT NEGLIGIBLE (QR STEP). C KASE = 4 IF E(M-1) IS NEGLIGIBLE (CONVERGENCE). C X 320 DO 330 LL=1,M X L=M-LL C ...EXIT X IF (L.EQ.0) GO TO 340 X TEST=DABS(S(L))+DABS(S(L+1)) X ZTEST=TEST+DABS(E(L)) X IF (ZTEST.NE.TEST) GO TO 330 X E(L)=0.0D0 C ......EXIT X GO TO 340 X 330 CONTINUE X 340 IF (L.NE.M-1) GO TO 350 X KASE=4 X GO TO 400 X 350 LP1=L+1 X MP1=M+1 X DO 360 LLS=LP1,MP1 X LS=M-LLS+LP1 C ...EXIT X IF (LS.EQ.L) GO TO 370 X TEST=0.0D0 X IF (LS.NE.M) TEST=TEST+DABS(E(LS)) X IF (LS.NE.L+1) TEST=TEST+DABS(E(LS-1)) X ZTEST=TEST+DABS(S(LS)) X IF (ZTEST.NE.TEST) GO TO 360 X S(LS)=0.0D0 C ......EXIT X GO TO 370 X 360 CONTINUE X 370 IF (LS.NE.L) GO TO 380 X KASE=3 X GO TO 400 X 380 IF (LS.NE.M) GO TO 390 X KASE=1 X GO TO 400 X 390 KASE=2 X L=LS X 400 L=L+1 C C PERFORM THE TASK INDICATED BY KASE. C X GO TO (410,440,460,490),KASE C C DEFLATE NEGLIGIBLE S(M). C X 410 MM1=M-1 X F=E(M-1) X E(M-1)=0.0D0 X DO 430 KK=L,MM1 X K=MM1-KK+L X T1=S(K) X CALL DROTG (T1,F,CS,SN) X S(K)=T1 X IF (K.EQ.L) GO TO 420 X F=-SN*E(K-1) X E(K-1)=CS*E(K-1) X 420 IF (WANTV) CALL DROT (P,V(1,K),1,V(1,M),1,CS,SN) X 430 CONTINUE X GO TO 310 C C SPLIT AT NEGLIGIBLE S(L). C X 440 F=E(L-1) X E(L-1)=0.0D0 X DO 450 K=L,M X T1=S(K) X CALL DROTG (T1,F,CS,SN) X S(K)=T1 X F=-SN*E(K) X E(K)=CS*E(K) X IF (WANTU) CALL DROT (N,U(1,K),1,U(1,L-1),1,CS,SN) X 450 CONTINUE X GO TO 310 C C PERFORM ONE QR STEP. C C C CALCULATE THE SHIFT. C X 460 SCALE=DMAX1(DABS(S(M)),DABS(S(M-1)),DABS(E(M-1)),DABS(S(L)), X $DABS(E(L))) X SM=S(M)/SCALE X SMM1=S(M-1)/SCALE X EMM1=E(M-1)/SCALE X SL=S(L)/SCALE X EL=E(L)/SCALE X B=((SMM1+SM)*(SMM1-SM)+EMM1**2)/2.0D0 X C=(SM*EMM1)**2 X SHIFT=0.0D0 X IF (B.EQ.0.0D0.AND.C.EQ.0.0D0) GO TO 470 X SHIFT=DSQRT(B**2+C) X IF (B.LT.0.0D0) SHIFT=-SHIFT X SHIFT=C/(B+SHIFT) X 470 F=(SL+SM)*(SL-SM)+SHIFT X G=SL*EL C C CHASE ZEROS. C X MM1=M-1 X DO 480 K=L,MM1 X CALL DROTG (F,G,CS,SN) X IF (K.NE.L) E(K-1)=F X F=CS*S(K)+SN*E(K) X E(K)=CS*E(K)-SN*S(K) X G=SN*S(K+1) X S(K+1)=CS*S(K+1) X IF (WANTV) CALL DROT (P,V(1,K),1,V(1,K+1),1,CS,SN) X CALL DROTG (F,G,CS,SN) X S(K)=F X F=CS*E(K)+SN*S(K+1) X S(K+1)=-SN*E(K)+CS*S(K+1) X G=SN*E(K+1) X E(K+1)=CS*E(K+1) X IF (WANTU.AND.K.LT.N) CALL DROT (N,U(1,K),1,U(1,K+1),1,CS,SN) X 480 CONTINUE X E(M-1)=F X ITER=ITER+1 X GO TO 310 C C CONVERGENCE. C C C MAKE THE SINGULAR VALUE POSITIVE. C X 490 IF (S(L).GE.0.0D0) GO TO 500 X S(L)=-S(L) X IF (WANTV) CALL DSCAL (P,-1.0D0,V(1,L),1) C C ORDER THE SINGULAR VALUE. C X 500 IF (L.EQ.MM) GO TO 510 C ...EXIT X IF (S(L).GE.S(L+1)) GO TO 510 X T=S(L) X S(L)=S(L+1) X S(L+1)=T X IF (WANTV.AND.L.LT.P) CALL DSWAP (P,V(1,L),1,V(1,L+1),1) X IF (WANTU.AND.L.LT.N) CALL DSWAP (N,U(1,L),1,U(1,L+1),1) X L=L+1 X GO TO 500 X 510 ITER=0 X M=M-1 X GO TO 310 X 520 RETURN X END C********************************************************************** C X SUBROUTINE DSWAP (N,DX,INCX,DY,INCY) C C interchanges two vectors. C uses unrolled loops for increments equal one. C jack dongarra, linpack, 3/11/78. C X DOUBLE PRECISION DX(1),DY(1),DTEMP X INTEGER I,INCX,INCY,IX,IY,M,MP1,N C X IF (N.LE.0) RETURN X IF (INCX.EQ.1.AND.INCY.EQ.1) GO TO 20 C C code for unequal increments or equal increments not equal C to 1 C 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 C C code for both increments equal to 1 C C C clean-up loop C 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 C C********************************************************************** C X INTEGER FUNCTION IDAMAX(N,DX,INCX) C C finds the index of element having max. absolute value. C jack dongarra, linpack, 3/11/78. C X DOUBLE PRECISION DX(1),DMAX X INTEGER I,INCX,IX,N C X IDAMAX=0 X IF (N.LT.1) RETURN X IDAMAX=1 X IF (N.EQ.1) RETURN X IF (INCX.EQ.1) GO TO 30 C C code for increment not equal to 1 C X IX=1 X DMAX=DABS(DX(1)) X IX=IX+INCX X DO 20 I=2,N X IF (DABS(DX(IX)).LE.DMAX) GO TO 10 X IDAMAX=I X DMAX=DABS(DX(IX)) X 10 IX=IX+INCX X 20 CONTINUE X RETURN C C code for increment equal to 1 C X 30 DMAX=DABS(DX(1)) X DO 40 I=2,N X IF (DABS(DX(I)).LE.DMAX) GO TO 40 X IDAMAX=I X DMAX=DABS(DX(I)) X 40 CONTINUE X RETURN X END C C********************************************************************** X SHAR_EOF chmod 0600 dble/sup/linpack.f || echo 'restore of dble/sup/linpack.f failed' Wc_c="`wc -c < 'dble/sup/linpack.f'`" test 42496 -eq "$Wc_c" || echo 'dble/sup/linpack.f: original size 42496, current size' "$Wc_c" fi # ============= dble/sup/support.f ============== if test -f 'dble/sup/support.f' -a X"$1" != X"-c"; then echo 'x - skipping dble/sup/support.f (File already exists)' else echo 'x - extracting dble/sup/support.f (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/sup/support.f' && C********************************************************************** C C Copyright (C) 1991 Noel M. Nachtigal C All rights reserved. C C This code is part of a copyrighted package. For details, see the C file `cpyrit.doc' in the current directory. C C ***************************************************************** C ANY USE OF THIS CODE CONSTITUES ACCEPTANCE OF THE TERMS OF THE C COPYRIGHT NOTICE C ***************************************************************** C C********************************************************************** C C This file contains miscellaneous support routines. C C********************************************************************** C X DOUBLE PRECISION FUNCTION DADD (DX,DY) C C Purpose: C Computes DX + DY. Used to ensure that the optimizer doesn't get C rid of the operation. C C Parameters: C DX = the first variable to add (input). C DY = the second variable to add (input). C C Noel M. Nachtigal C November 18, 1987 C X DOUBLE PRECISION DX, DY C X DADD = DX + DY C X RETURN X END C C********************************************************************** C X DOUBLE PRECISION FUNCTION DEPS () C C Purpose: C Computes double precision machine epsilon, the smallest number C which, when added to 1.0, gives 1.0. This function could use the C radix of the machine to obtain a better estimate, but its result C is good enough for our purposes. It does attempt to ensure that C any optimization does not affect the result. C C External routines used: C double precision dadd(dx,dy) C Computes dx = dx + dy. Used to get around optimizers. C C Noel M. Nachtigal C October 25, 1990 C X EXTERNAL DADD X DOUBLE PRECISION DADD C C Local variables. C X DOUBLE PRECISION DTMP C X DTMP = 1.0D0 C X 30 IF (DADD(DTMP,1.0D0).GT.1.0) THEN X DTMP = DTMP / 2.0 X GO TO 30 X END IF C X DEPS = DTMP C X RETURN X END C C********************************************************************** C X SUBROUTINE HSORT (N,X,Y) C C Purpose: C This subroutine sorts the array X using HeapSort. It rearranges C the elements of Y at the same time, thus making it suitable for C sorting complex number based on the real or imaginary part. The C code is copied verbatim from Numerical Recipes (minus the bugs). C C Parameters: C N = the length of the arrays (input). C X = the primary array to be used in sorting (input/output). C Y = the secondary array, sorted in the same order (input/output). C C Noel M. Nachtigal C October 4, 1990 C X INTEGER N X DOUBLE PRECISION X(*), Y(*) C C Local variables. C X INTEGER I, J, K, L X DOUBLE PRECISION TMPX, TMPY C X IF (N.LE.1) RETURN C X L = N / 2 + 1 X K = N X 10 IF (L.GT.1) THEN X L = L - 1 X TMPX = X(L) X TMPY = Y(L) X ELSE X TMPX = X(K) X TMPY = Y(K) X X(K) = X(1) X Y(K) = Y(1) X K = K - 1 X IF (K.LE.1) THEN X X(1) = TMPX X Y(1) = TMPY X RETURN X END IF X END IF X I = L X J = L + L X 20 IF (J.LE.K) THEN X IF (J.LT.K) THEN X IF (X(J).LT.X(J+1)) J = J + 1 X END IF X IF (TMPX.LT.X(J)) THEN X X(I) = X(J) X Y(I) = Y(J) X I = J X J = J + J X ELSE X J = K + 1 X END IF X GO TO 20 X END IF X X(I) = TMPX X Y(I) = TMPY X GO TO 10 X END C C********************************************************************** SHAR_EOF chmod 0600 dble/sup/support.f || echo 'restore of dble/sup/support.f failed' Wc_c="`wc -c < 'dble/sup/support.f'`" test 3728 -eq "$Wc_c" || echo 'dble/sup/support.f: original size 3728, current size' "$Wc_c" fi # ============= dble/sup/eispack.f ============== if test -f 'dble/sup/eispack.f' -a X"$1" != X"-c"; then echo 'x - skipping dble/sup/eispack.f (File already exists)' else echo 'x - extracting dble/sup/eispack.f (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/sup/eispack.f' && C********************************************************************** C C These are support routines from EISPACK. C C********************************************************************** C X SUBROUTINE BALANC(NM,N,A,LOW,IGH,SCALE) C X INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC X DOUBLE PRECISION A(NM,N),SCALE(N) X DOUBLE PRECISION C,F,G,R,S,B2,RADIX X LOGICAL NOCONV C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BALANCE, C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). C C THIS SUBROUTINE BALANCES A REAL MATRIX AND ISOLATES C EIGENVALUES WHENEVER POSSIBLE. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C N IS THE ORDER OF THE MATRIX. C C A CONTAINS THE INPUT MATRIX TO BE BALANCED. C C ON OUTPUT C C A CONTAINS THE BALANCED MATRIX. C C LOW AND IGH ARE TWO INTEGERS SUCH THAT A(I,J) C IS EQUAL TO ZERO IF C (1) I IS GREATER THAN J AND C (2) J=1,...,LOW-1 OR I=IGH+1,...,N. C C SCALE CONTAINS INFORMATION DETERMINING THE C PERMUTATIONS AND SCALING FACTORS USED. C C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN C SCALE(J) = P(J), FOR J = 1,...,LOW-1 C = D(J,J), J = LOW,...,IGH C = P(J) J = IGH+1,...,N. C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1, C THEN 1 TO LOW-1. C C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY. C C THE ALGOL PROCEDURE EXC CONTAINED IN BALANCE APPEARS IN C BALANC IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS C K,L HAVE BEEN REVERSED.) C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED AUGUST 1983. C C ------------------------------------------------------------------ C X RADIX = 16.0D0 C X B2 = RADIX * RADIX X K = 1 X L = N X GO TO 100 C .......... IN-LINE PROCEDURE FOR ROW AND C COLUMN EXCHANGE .......... X 20 SCALE(M) = J X IF (J .EQ. M) GO TO 50 C X DO 30 I = 1, L X F = A(I,J) X A(I,J) = A(I,M) X A(I,M) = F X 30 CONTINUE C X DO 40 I = K, N X F = A(J,I) X A(J,I) = A(M,I) X A(M,I) = F X 40 CONTINUE C X 50 GO TO (80,130), IEXC C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE C AND PUSH THEM DOWN .......... X 80 IF (L .EQ. 1) GO TO 280 X L = L - 1 C .......... FOR J=L STEP -1 UNTIL 1 DO -- .......... X 100 DO 120 JJ = 1, L X J = L + 1 - JJ C X DO 110 I = 1, L X IF (I .EQ. J) GO TO 110 X IF (A(J,I) .NE. 0.0D0) GO TO 120 X 110 CONTINUE C X M = L X IEXC = 1 X GO TO 20 X 120 CONTINUE C X GO TO 140 C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE C AND PUSH THEM LEFT .......... X 130 K = K + 1 C X 140 DO 170 J = K, L C X DO 150 I = K, L X IF (I .EQ. J) GO TO 150 X IF (A(I,J) .NE. 0.0D0) GO TO 170 X 150 CONTINUE C X M = K X IEXC = 2 X GO TO 20 X 170 CONTINUE C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L .......... X DO 180 I = K, L X X 180 SCALE(I) = 1.0D0 C .......... ITERATIVE LOOP FOR NORM REDUCTION .......... X 190 NOCONV = .FALSE. C X DO 270 I = K, L X C = 0.0D0 X R = 0.0D0 C X DO 200 J = K, L X IF (J .EQ. I) GO TO 200 X C = C + DABS(A(J,I)) X R = R + DABS(A(I,J)) X 200 CONTINUE C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW .......... X IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GO TO 270 X G = R / RADIX X F = 1.0D0 X S = C + R X 210 IF (C .GE. G) GO TO 220 X F = F * RADIX X C = C * B2 X GO TO 210 X 220 G = R * RADIX X 230 IF (C .LT. G) GO TO 240 X F = F / RADIX X C = C / B2 X GO TO 230 C .......... NOW BALANCE .......... X 240 IF ((C + R) / F .GE. 0.95D0 * S) GO TO 270 X G = 1.0D0 / F X SCALE(I) = SCALE(I) * F X NOCONV = .TRUE. C X DO 250 J = K, N X 250 A(I,J) = A(I,J) * G C X DO 260 J = 1, L X 260 A(J,I) = A(J,I) * F C X 270 CONTINUE C X IF (NOCONV) GO TO 190 C X 280 LOW = K X IGH = L X RETURN X END C C********************************************************************** C X SUBROUTINE DHQR(NM,N,LOW,IGH,H,WR,WI,IERR) C X INTEGER I,J,K,L,M,N,EN,LL,MM,NA,NM,IGH,ITN,ITS,LOW,MP2,ENM2,IERR X DOUBLE PRECISION H(NM,N),WR(N),WI(N) X DOUBLE PRECISION P,Q,R,S,T,W,X,Y,ZZ,NORM,TST1,TST2 X LOGICAL NOTLAS C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE HQR, C NUM. MATH. 14, 219-231(1970) BY MARTIN, PETERS, AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 359-371(1971). C C THIS SUBROUTINE FINDS THE EIGENVALUES OF A REAL C UPPER HESSENBERG MATRIX BY THE QR METHOD. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C N IS THE ORDER OF THE MATRIX. C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, C SET LOW=1, IGH=N. C C H CONTAINS THE UPPER HESSENBERG MATRIX. INFORMATION ABOUT C THE TRANSFORMATIONS USED IN THE REDUCTION TO HESSENBERG C FORM BY ELMHES OR ORTHES, IF PERFORMED, IS STORED C IN THE REMAINING TRIANGLE UNDER THE HESSENBERG MATRIX. C C ON OUTPUT C C H HAS BEEN DESTROYED. THEREFORE, IT MUST BE SAVED C BEFORE CALLING HQR IF SUBSEQUENT CALCULATION AND C BACK TRANSFORMATION OF EIGENVECTORS IS TO BE PERFORMED. C C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE EIGENVALUES. THE EIGENVALUES C ARE UNORDERED EXCEPT THAT COMPLEX CONJUGATE PAIRS C OF VALUES APPEAR CONSECUTIVELY WITH THE EIGENVALUE C HAVING THE POSITIVE IMAGINARY PART FIRST. IF AN C ERROR EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT C FOR INDICES IERR+1,...,N. C C IERR IS SET TO C ZERO FOR NORMAL RETURN, C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED AUGUST 1983. C C ------------------------------------------------------------------ C X IERR = 0 X NORM = 0.0D0 X K = 1 C .......... STORE ROOTS ISOLATED BY BALANC C AND COMPUTE MATRIX NORM .......... X DO 50 I = 1, N C X DO 40 J = K, N X 40 NORM = NORM + DABS(H(I,J)) C X K = I X IF (I .GE. LOW .AND. I .LE. IGH) GO TO 50 X WR(I) = H(I,I) X WI(I) = 0.0D0 X 50 CONTINUE C X EN = IGH X T = 0.0D0 X ITN = 30*N C .......... SEARCH FOR NEXT EIGENVALUES .......... X 60 IF (EN .LT. LOW) GO TO 1001 X ITS = 0 X NA = EN - 1 X ENM2 = NA - 1 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT C FOR L=EN STEP -1 UNTIL LOW DO -- .......... X 70 DO 80 LL = LOW, EN X L = EN + LOW - LL X IF (L .EQ. LOW) GO TO 100 X S = DABS(H(L-1,L-1)) + DABS(H(L,L)) X IF (S .EQ. 0.0D0) S = NORM X TST1 = S X TST2 = TST1 + DABS(H(L,L-1)) X IF (TST2 .EQ. TST1) GO TO 100 X 80 CONTINUE C .......... FORM SHIFT .......... X 100 X = H(EN,EN) X IF (L .EQ. EN) GO TO 270 X Y = H(NA,NA) X W = H(EN,NA) * H(NA,EN) X IF (L .EQ. NA) GO TO 280 X IF (ITN .EQ. 0) GO TO 1000 X IF (ITS .NE. 10 .AND. ITS .NE. 20) GO TO 130 C .......... FORM EXCEPTIONAL SHIFT .......... X T = T + X C X DO 120 I = LOW, EN X 120 H(I,I) = H(I,I) - X C X S = DABS(H(EN,NA)) + DABS(H(NA,ENM2)) X X = 0.75D0 * S X Y = X X W = -0.4375D0 * S * S X 130 ITS = ITS + 1 X ITN = ITN - 1 C .......... LOOK FOR TWO CONSECUTIVE SMALL C SUB-DIAGONAL ELEMENTS. C FOR M=EN-2 STEP -1 UNTIL L DO -- .......... X DO 140 MM = L, ENM2 X M = ENM2 + L - MM X ZZ = H(M,M) X R = X - ZZ X S = Y - ZZ X P = (R * S - W) / H(M+1,M) + H(M,M+1) X Q = H(M+1,M+1) - ZZ - R - S X R = H(M+2,M+1) X S = DABS(P) + DABS(Q) + DABS(R) X P = P / S X Q = Q / S X R = R / S X IF (M .EQ. L) GO TO 150 X TST1 = DABS(P)*(DABS(H(M-1,M-1)) + DABS(ZZ) + DABS(H(M+1,M+1))) X TST2 = TST1 + DABS(H(M,M-1))*(DABS(Q) + DABS(R)) X IF (TST2 .EQ. TST1) GO TO 150 X 140 CONTINUE C X 150 MP2 = M + 2 C X DO 160 I = MP2, EN X H(I,I-2) = 0.0D0 X IF (I .EQ. MP2) GO TO 160 X H(I,I-3) = 0.0D0 X 160 CONTINUE C .......... DOUBLE QR STEP INVOLVING ROWS L TO EN AND C COLUMNS M TO EN .......... X DO 260 K = M, NA X NOTLAS = K .NE. NA X IF (K .EQ. M) GO TO 170 X P = H(K,K-1) X Q = H(K+1,K-1) X R = 0.0D0 X IF (NOTLAS) R = H(K+2,K-1) X X = DABS(P) + DABS(Q) + DABS(R) X IF (X .EQ. 0.0D0) GO TO 260 X P = P / X X Q = Q / X X R = R / X X 170 S = DSIGN(DSQRT(P*P+Q*Q+R*R),P) X IF (K .EQ. M) GO TO 180 X H(K,K-1) = -S * X X GO TO 190 X 180 IF (L .NE. M) H(K,K-1) = -H(K,K-1) X 190 P = P + S X X = P / S X Y = Q / S X ZZ = R / S X Q = Q / P X R = R / P X IF (NOTLAS) GO TO 225 C .......... ROW MODIFICATION .......... X DO 200 J = K, N X P = H(K,J) + Q * H(K+1,J) X H(K,J) = H(K,J) - P * X X H(K+1,J) = H(K+1,J) - P * Y X 200 CONTINUE C X J = MIN0(EN,K+3) C .......... COLUMN MODIFICATION .......... X DO 210 I = 1, J X P = X * H(I,K) + Y * H(I,K+1) X H(I,K) = H(I,K) - P X H(I,K+1) = H(I,K+1) - P * Q X 210 CONTINUE X GO TO 255 X 225 CONTINUE C .......... ROW MODIFICATION .......... X DO 230 J = K, N X P = H(K,J) + Q * H(K+1,J) + R * H(K+2,J) X H(K,J) = H(K,J) - P * X X H(K+1,J) = H(K+1,J) - P * Y X H(K+2,J) = H(K+2,J) - P * ZZ X 230 CONTINUE C X J = MIN0(EN,K+3) C .......... COLUMN MODIFICATION .......... X DO 240 I = 1, J X P = X * H(I,K) + Y * H(I,K+1) + ZZ * H(I,K+2) X H(I,K) = H(I,K) - P X H(I,K+1) = H(I,K+1) - P * Q X H(I,K+2) = H(I,K+2) - P * R X 240 CONTINUE X 255 CONTINUE C X 260 CONTINUE C X GO TO 70 C .......... ONE ROOT FOUND .......... X 270 WR(EN) = X + T X WI(EN) = 0.0D0 X EN = NA X GO TO 60 C .......... TWO ROOTS FOUND .......... X 280 P = (Y - X) / 2.0D0 X Q = P * P + W X ZZ = DSQRT(DABS(Q)) X X = X + T X IF (Q .LT. 0.0D0) GO TO 320 C .......... REAL PAIR .......... X ZZ = P + DSIGN(ZZ,P) X WR(NA) = X + ZZ X WR(EN) = WR(NA) X IF (ZZ .NE. 0.0D0) WR(EN) = X - W / ZZ X WI(NA) = 0.0D0 X WI(EN) = 0.0D0 X GO TO 330 C .......... COMPLEX PAIR .......... X 320 WR(NA) = X + P X WR(EN) = X + P X WI(NA) = ZZ X WI(EN) = -ZZ X 330 EN = ENM2 X GO TO 60 C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT C CONVERGED AFTER 30*N ITERATIONS .......... X 1000 IERR = EN X 1001 RETURN X END C C********************************************************************** C X SUBROUTINE QZHES (NM,N,A,B,MATZ,Z) C X INTEGER I,J,K,L,N,LB,L1,NM,NK1,NM1,NM2 X DOUBLE PRECISION A(NM,N),B(NM,N),Z(NM,N) X DOUBLE PRECISION R,S,T,U1,U2,V1,V2,RHO X LOGICAL MATZ C C this subroutine is the first step of the qz algorithm C for solving generalized matrix eigenvalue problems, C siam j. numer. anal. 10, 241-256(1973) by moler and stewart. C C this subroutine accepts a pair of real general matrices and C reduces one of them to upper hessenberg form and the other C to upper triangular form using orthogonal transformations. C it is usually followed by qzit, qzval and, possibly, qzvec. C C on input C C nm must be set to the row dimension of two-dimensional C array parameters as declared in the calling program C dimension statement. C C n is the order of the matrices. C C a contains a real general matrix. C C b contains a real general matrix. C C matz should be set to .true. if the right hand transformations C are to be accumulated for later use in computing C eigenvectors, and to .false. otherwise. C C on output C C a has been reduced to upper hessenberg form. the elements C below the first subdiagonal have been set to zero. C C b has been reduced to upper triangular form. the elements C below the main diagonal have been set to zero. C C z contains the product of the right hand transformations if C matz has been set to .true. otherwise, z is not referenced. C C questions and comments should be directed to burton s. garbow, C mathematics and computer science div, argonne national laboratory C C this version dated august 1983. C C ------------------------------------------------------------------ C C .......... initialize z .......... X IF (.NOT.MATZ) GO TO 30 C X DO 20 J=1,N C X DO 10 I=1,N X Z(I,J)=0.0D0 X 10 CONTINUE C X Z(J,J)=1.0D0 X 20 CONTINUE C .......... reduce b to upper triangular form .......... X 30 IF (N.LE.1) GO TO 210 X NM1=N-1 C X DO 130 L=1,NM1 X L1=L+1 X S=0.0D0 C X DO 40 I=L1,N X S=S+DABS(B(I,L)) X 40 CONTINUE C X IF (S.EQ.0.0D0) GO TO 130 X S=S+DABS(B(L,L)) X R=0.0D0 C X DO 50 I=L,N X B(I,L)=B(I,L)/S X R=R+B(I,L)**2 X 50 CONTINUE C X R=DSIGN(DSQRT(R),B(L,L)) X B(L,L)=B(L,L)+R X RHO=R*B(L,L) C X DO 80 J=L1,N X T=0.0D0 C X DO 60 I=L,N X T=T+B(I,L)*B(I,J) X 60 CONTINUE C X T=-T/RHO C X DO 70 I=L,N X B(I,J)=B(I,J)+T*B(I,L) X 70 CONTINUE C X 80 CONTINUE C X DO 110 J=1,N X T=0.0D0 C X DO 90 I=L,N X T=T+B(I,L)*A(I,J) X 90 CONTINUE C X T=-T/RHO C X DO 100 I=L,N X A(I,J)=A(I,J)+T*B(I,L) X 100 CONTINUE C X 110 CONTINUE C X B(L,L)=-S*R C X DO 120 I=L1,N X B(I,L)=0.0D0 X 120 CONTINUE C X 130 CONTINUE C .......... reduce a to upper hessenberg form, while C keeping b triangular .......... X IF (N.EQ.2) GO TO 210 X NM2=N-2 C X DO 200 K=1,NM2 X NK1=NM1-K C .......... for l=n-1 step -1 until k+1 do -- .......... X DO 190 LB=1,NK1 X L=N-LB X L1=L+1 C .......... zero a(l+1,k) .......... X S=DABS(A(L,K))+DABS(A(L1,K)) X IF (S.EQ.0.0D0) GO TO 190 X U1=A(L,K)/S X U2=A(L1,K)/S X R=DSIGN(DSQRT(U1*U1+U2*U2),U1) X V1=-(U1+R)/R X V2=-U2/R X U2=V2/V1 C X DO 140 J=K,N X T=A(L,J)+U2*A(L1,J) X A(L,J)=A(L,J)+T*V1 X A(L1,J)=A(L1,J)+T*V2 X 140 CONTINUE C X A(L1,K)=0.0D0 C X DO 150 J=L,N X T=B(L,J)+U2*B(L1,J) X B(L,J)=B(L,J)+T*V1 X B(L1,J)=B(L1,J)+T*V2 X 150 CONTINUE C .......... zero b(l+1,l) .......... X S=DABS(B(L1,L1))+DABS(B(L1,L)) X IF (S.EQ.0.0D0) GO TO 190 X U1=B(L1,L1)/S X U2=B(L1,L)/S X R=DSIGN(DSQRT(U1*U1+U2*U2),U1) X V1=-(U1+R)/R X V2=-U2/R X U2=V2/V1 C X DO 160 I=1,L1 X T=B(I,L1)+U2*B(I,L) X B(I,L1)=B(I,L1)+T*V1 X B(I,L)=B(I,L)+T*V2 X 160 CONTINUE C X B(L1,L)=0.0D0 C X DO 170 I=1,N X T=A(I,L1)+U2*A(I,L) X A(I,L1)=A(I,L1)+T*V1 X A(I,L)=A(I,L)+T*V2 X 170 CONTINUE C X IF (.NOT.MATZ) GO TO 190 C X DO 180 I=1,N X T=Z(I,L1)+U2*Z(I,L) X Z(I,L1)=Z(I,L1)+T*V1 X Z(I,L)=Z(I,L)+T*V2 X 180 CONTINUE C X 190 CONTINUE C X 200 CONTINUE C X 210 RETURN X END C C********************************************************************** C X SUBROUTINE QZIT (NM,N,A,B,EPS1,MATZ,Z,IERR) C X INTEGER I,J,K,L,N,EN,K1,K2,LD,LL,L1,NA,NM,ISH,ITN,ITS,KM1,LM1, X $ENM2,IERR,LOR1,ENORN X DOUBLE PRECISION A(NM,N),B(NM,N),Z(NM,N) X DOUBLE PRECISION R,S,T,A1,A2,A3,EP,SH,U1,U2,U3,V1,V2,V3,ANI,A11, X $A12,A21,A22,A33,A34,A43,A44,BNI,B11,B12,B22,B33,B34,B44,EPSA,EPSB, X $EPS1,ANORM,BNORM,EPSLON X LOGICAL MATZ,NOTLAS C C this subroutine is the second step of the qz algorithm C for solving generalized matrix eigenvalue problems, C siam j. numer. anal. 10, 241-256(1973) by moler and stewart, C as modified in technical note nasa tn d-7305(1973) by ward. C C this subroutine accepts a pair of real matrices, one of them C in upper hessenberg form and the other in upper triangular form. C it reduces the hessenberg matrix to quasi-triangular form using C orthogonal transformations while maintaining the triangular form C of the other matrix. it is usually preceded by qzhes and C followed by qzval and, possibly, qzvec. C C on input C C nm must be set to the row dimension of two-dimensional C array parameters as declared in the calling program C dimension statement. C C n is the order of the matrices. C C a contains a real upper hessenberg matrix. C C b contains a real upper triangular matrix. C C eps1 is a tolerance used to determine negligible elements. C eps1 = 0.0 (or negative) may be input, in which case an C element will be neglected only if it is less than roundoff C error times the norm of its matrix. if the input eps1 is C positive, then an element will be considered negligible C if it is less than eps1 times the norm of its matrix. a C positive value of eps1 may result in faster execution, C but less accurate results. C C matz should be set to .true. if the right hand transformations C are to be accumulated for later use in computing C eigenvectors, and to .false. otherwise. C C z contains, if matz has been set to .true., the C transformation matrix produced in the reduction C by qzhes, if performed, or else the identity matrix. C if matz has been set to .false., z is not referenced. C C on output C C a has been reduced to quasi-triangular form. the elements C below the first subdiagonal are still zero and no two C consecutive subdiagonal elements are nonzero. C C b is still in upper triangular form, although its elements C have been altered. the location b(n,1) is used to store C eps1 times the norm of b for later use by qzval and qzvec. C C z contains the product of the right hand transformations C (for both steps) if matz has been set to .true.. C C ierr is set to C zero for normal return, C j if the limit of 30*n iterations is exhausted C while the j-th eigenvalue is being sought. C C questions and comments should be directed to burton s. garbow, C mathematics and computer science div, argonne national laboratory C C this version dated august 1983. C C ------------------------------------------------------------------ C X IERR=0 C .......... compute epsa,epsb .......... X ANORM=0.0D0 X BNORM=0.0D0 C X DO 20 I=1,N X ANI=0.0D0 X IF (I.NE.1) ANI=DABS(A(I,I-1)) X BNI=0.0D0 C X DO 10 J=I,N X ANI=ANI+DABS(A(I,J)) X BNI=BNI+DABS(B(I,J)) X 10 CONTINUE C X IF (ANI.GT.ANORM) ANORM=ANI X IF (BNI.GT.BNORM) BNORM=BNI X 20 CONTINUE C X IF (ANORM.EQ.0.0D0) ANORM=1.0D0 X IF (BNORM.EQ.0.0D0) BNORM=1.0D0 X EP=EPS1 X IF (EP.GT.0.0D0) GO TO 30 C .......... use roundoff level if eps1 is zero .......... X EP=EPSLON(1.0D0) X 30 EPSA=EP*ANORM X EPSB=EP*BNORM C .......... reduce a to quasi-triangular form, while C keeping b triangular .......... X LOR1=1 X ENORN=N X EN=N X ITN=30*N C .......... begin qz step .......... X 40 IF (EN.LE.2) GO TO 300 X IF (.NOT.MATZ) ENORN=EN X ITS=0 X NA=EN-1 X ENM2=NA-1 X 50 ISH=2 C .......... check for convergence or reducibility. C for l=en step -1 until 1 do -- .......... X DO 60 LL=1,EN X LM1=EN-LL X L=LM1+1 X IF (L.EQ.1) GO TO 80 X IF (DABS(A(L,LM1)).LE.EPSA) GO TO 70 X 60 CONTINUE C X 70 A(L,LM1)=0.0D0 X IF (L.LT.NA) GO TO 80 C .......... 1-by-1 or 2-by-2 block isolated .......... X EN=LM1 X GO TO 40 C .......... check for small top of b .......... X 80 LD=L X 90 L1=L+1 X B11=B(L,L) X IF (DABS(B11).GT.EPSB) GO TO 110 X B(L,L)=0.0D0 X S=DABS(A(L,L))+DABS(A(L1,L)) X U1=A(L,L)/S X U2=A(L1,L)/S X R=DSIGN(DSQRT(U1*U1+U2*U2),U1) X V1=-(U1+R)/R X V2=-U2/R X U2=V2/V1 C X DO 100 J=L,ENORN X T=A(L,J)+U2*A(L1,J) X A(L,J)=A(L,J)+T*V1 X A(L1,J)=A(L1,J)+T*V2 X T=B(L,J)+U2*B(L1,J) X B(L,J)=B(L,J)+T*V1 X B(L1,J)=B(L1,J)+T*V2 X 100 CONTINUE C X IF (L.NE.1) A(L,LM1)=-A(L,LM1) X LM1=L X L=L1 X GO TO 70 X 110 A11=A(L,L)/B11 X A21=A(L1,L)/B11 X IF (ISH.EQ.1) GO TO 130 C .......... iteration strategy .......... X IF (ITN.EQ.0) GO TO 290 X IF (ITS.EQ.10) GO TO 150 C .......... determine type of shift .......... X B22=B(L1,L1) X IF (DABS(B22).LT.EPSB) B22=EPSB X B33=B(NA,NA) X IF (DABS(B33).LT.EPSB) B33=EPSB X B44=B(EN,EN) X IF (DABS(B44).LT.EPSB) B44=EPSB X A33=A(NA,NA)/B33 X A34=A(NA,EN)/B44 X A43=A(EN,NA)/B33 X A44=A(EN,EN)/B44 X B34=B(NA,EN)/B44 X T=0.5D0*(A43*B34-A33-A44) X R=T*T+A34*A43-A33*A44 X IF (R.LT.0.0D0) GO TO 140 C .......... determine single shift zeroth column of a .......... X ISH=1 X R=DSQRT(R) X SH=-T+R X S=-T-R X IF (DABS(S-A44).LT.DABS(SH-A44)) SH=S C .......... look for two consecutive small C sub-diagonal elements of a. C for l=en-2 step -1 until ld do -- .......... X DO 120 LL=LD,ENM2 X L=ENM2+LD-LL X IF (L.EQ.LD) GO TO 130 X LM1=L-1 X L1=L+1 X T=A(L,L) X IF (DABS(B(L,L)).GT.EPSB) T=T-SH*B(L,L) X IF (DABS(A(L,LM1)).LE.DABS(T/A(L1,L))*EPSA) GO TO 90 X 120 CONTINUE C X 130 A1=A11-SH X A2=A21 X IF (L.NE.LD) A(L,LM1)=-A(L,LM1) X GO TO 160 C .......... determine double shift zeroth column of a .......... X 140 A12=A(L,L1)/B22 X A22=A(L1,L1)/B22 X B12=B(L,L1)/B22 X A1=((A33-A11)*(A44-A11)-A34*A43+A43*B34*A11)/A21+A12-A11*B12 X A2=(A22-A11)-A21*B12-(A33-A11)-(A44-A11)+A43*B34 X A3=A(L1+1,L1)/B22 X GO TO 160 C .......... ad hoc shift .......... X 150 A1=0.0D0 X A2=1.0D0 X A3=1.1605D0 X 160 ITS=ITS+1 X ITN=ITN-1 X IF (.NOT.MATZ) LOR1=LD C .......... main loop .......... X DO 280 K=L,NA X NOTLAS=K.NE.NA.AND.ISH.EQ.2 X K1=K+1 X K2=K+2 X KM1=MAX0(K-1,L) X LL=MIN0(EN,K1+ISH) X IF (NOTLAS) GO TO 190 C .......... zero a(k+1,k-1) .......... X IF (K.EQ.L) GO TO 170 X A1=A(K,KM1) X A2=A(K1,KM1) X 170 S=DABS(A1)+DABS(A2) X IF (S.EQ.0.0D0) GO TO 50 X U1=A1/S X U2=A2/S X R=DSIGN(DSQRT(U1*U1+U2*U2),U1) X V1=-(U1+R)/R X V2=-U2/R X U2=V2/V1 C X DO 180 J=KM1,ENORN X T=A(K,J)+U2*A(K1,J) X A(K,J)=A(K,J)+T*V1 X A(K1,J)=A(K1,J)+T*V2 X T=B(K,J)+U2*B(K1,J) X B(K,J)=B(K,J)+T*V1 X B(K1,J)=B(K1,J)+T*V2 X 180 CONTINUE C X IF (K.NE.L) A(K1,KM1)=0.0D0 X GO TO 250 C .......... zero a(k+1,k-1) and a(k+2,k-1) .......... X 190 IF (K.EQ.L) GO TO 200 X A1=A(K,KM1) X A2=A(K1,KM1) X A3=A(K2,KM1) X 200 S=DABS(A1)+DABS(A2)+DABS(A3) X IF (S.EQ.0.0D0) GO TO 280 X U1=A1/S X U2=A2/S X U3=A3/S X R=DSIGN(DSQRT(U1*U1+U2*U2+U3*U3),U1) X V1=-(U1+R)/R X V2=-U2/R X V3=-U3/R X U2=V2/V1 X U3=V3/V1 C X DO 210 J=KM1,ENORN X T=A(K,J)+U2*A(K1,J)+U3*A(K2,J) X A(K,J)=A(K,J)+T*V1 X A(K1,J)=A(K1,J)+T*V2 X A(K2,J)=A(K2,J)+T*V3 X T=B(K,J)+U2*B(K1,J)+U3*B(K2,J) X B(K,J)=B(K,J)+T*V1 X B(K1,J)=B(K1,J)+T*V2 X B(K2,J)=B(K2,J)+T*V3 X 210 CONTINUE C X IF (K.EQ.L) GO TO 220 X A(K1,KM1)=0.0D0 X A(K2,KM1)=0.0D0 C .......... zero b(k+2,k+1) and b(k+2,k) .......... X 220 S=DABS(B(K2,K2))+DABS(B(K2,K1))+DABS(B(K2,K)) X IF (S.EQ.0.0D0) GO TO 250 X U1=B(K2,K2)/S X U2=B(K2,K1)/S X U3=B(K2,K)/S X R=DSIGN(DSQRT(U1*U1+U2*U2+U3*U3),U1) X V1=-(U1+R)/R X V2=-U2/R X V3=-U3/R X U2=V2/V1 X U3=V3/V1 C X DO 230 I=LOR1,LL X T=A(I,K2)+U2*A(I,K1)+U3*A(I,K) X A(I,K2)=A(I,K2)+T*V1 X A(I,K1)=A(I,K1)+T*V2 X A(I,K)=A(I,K)+T*V3 X T=B(I,K2)+U2*B(I,K1)+U3*B(I,K) X B(I,K2)=B(I,K2)+T*V1 X B(I,K1)=B(I,K1)+T*V2 X B(I,K)=B(I,K)+T*V3 X 230 CONTINUE C X B(K2,K)=0.0D0 X B(K2,K1)=0.0D0 X IF (.NOT.MATZ) GO TO 250 C X DO 240 I=1,N X T=Z(I,K2)+U2*Z(I,K1)+U3*Z(I,K) X Z(I,K2)=Z(I,K2)+T*V1 X Z(I,K1)=Z(I,K1)+T*V2 X Z(I,K)=Z(I,K)+T*V3 X 240 CONTINUE C .......... zero b(k+1,k) .......... X 250 S=DABS(B(K1,K1))+DABS(B(K1,K)) X IF (S.EQ.0.0D0) GO TO 280 X U1=B(K1,K1)/S X U2=B(K1,K)/S X R=DSIGN(DSQRT(U1*U1+U2*U2),U1) X V1=-(U1+R)/R X V2=-U2/R X U2=V2/V1 C X DO 260 I=LOR1,LL X T=A(I,K1)+U2*A(I,K) X A(I,K1)=A(I,K1)+T*V1 X A(I,K)=A(I,K)+T*V2 X T=B(I,K1)+U2*B(I,K) X B(I,K1)=B(I,K1)+T*V1 X B(I,K)=B(I,K)+T*V2 X 260 CONTINUE C X B(K1,K)=0.0D0 X IF (.NOT.MATZ) GO TO 280 C X DO 270 I=1,N X T=Z(I,K1)+U2*Z(I,K) X Z(I,K1)=Z(I,K1)+T*V1 X Z(I,K)=Z(I,K)+T*V2 X 270 CONTINUE C X 280 CONTINUE C .......... end qz step .......... X GO TO 50 C .......... set error -- all eigenvalues have not C converged after 30*n iterations .......... X 290 IERR=EN C .......... save epsb for use by qzval and qzvec .......... X 300 IF (N.GT.1) B(N,1)=EPSB X RETURN X END C C********************************************************************** C X DOUBLE PRECISION FUNCTION EPSLON (X) X DOUBLE PRECISION X C C estimate unit roundoff in quantities of size x. C X DOUBLE PRECISION A,B,C,EPS C C this program should function properly on all systems C satisfying the following two assumptions, C 1. the base used in representing floating point C numbers is not a power of three. C 2. the quantity a in statement 10 is represented to C the accuracy used in floating point variables C that are stored in memory. C the statement number 10 and the go to 10 are intended to C force optimizing compilers to generate code satisfying C assumption 2. C under these assumptions, it should be true that, C a is not exactly equal to four-thirds, C b has a zero for its last bit or digit, C c is not exactly equal to one, C eps measures the separation of 1.0 from C the next larger floating point number. C the developers of eispack would appreciate being informed C about any systems where these assumptions do not hold. C C this version dated 4/6/83. C X A=4.0D0/3.0D0 X 10 B=A-1.0D0 X C=B+B+B X EPS=DABS(C-1.0D0) X IF (EPS.EQ.0.0D0) GO TO 10 X EPSLON=EPS*DABS(X) X RETURN X END C C********************************************************************** C X SUBROUTINE QZVAL (NM,N,A,B,ALFR,ALFI,BETA,MATZ,Z) C X INTEGER I,J,N,EN,NA,NM,NN,ISW X DOUBLE PRECISION A(NM,N),B(NM,N),ALFR(N),ALFI(N),BETA(N),Z(NM,N) X DOUBLE PRECISION C,D,E,R,S,T,AN,A1,A2,BN,CQ,CZ,DI,DR,EI,TI,TR,U1, X $U2,V1,V2,A1I,A11,A12,A2I,A21,A22,B11,B12,B22,SQI,SQR,SSI,SSR,SZI, X $SZR,A11I,A11R,A12I,A12R,A22I,A22R,EPSB X LOGICAL MATZ C C this subroutine is the third step of the qz algorithm C for solving generalized matrix eigenvalue problems, C siam j. numer. anal. 10, 241-256(1973) by moler and stewart. C C this subroutine accepts a pair of real matrices, one of them C in quasi-triangular form and the other in upper triangular form. C it reduces the quasi-triangular matrix further, so that any C remaining 2-by-2 blocks correspond to pairs of complex C eigenvalues, and returns quantities whose ratios give the C generalized eigenvalues. it is usually preceded by qzhes C and qzit and may be followed by qzvec. C C on input C C nm must be set to the row dimension of two-dimensional C array parameters as declared in the calling program C dimension statement. C C n is the order of the matrices. C C a contains a real upper quasi-triangular matrix. C C b contains a real upper triangular matrix. in addition, C location b(n,1) contains the tolerance quantity (epsb) C computed and saved in qzit. C C matz should be set to .true. if the right hand transformations C are to be accumulated for later use in computing C eigenvectors, and to .false. otherwise. C C z contains, if matz has been set to .true., the C transformation matrix produced in the reductions by qzhes C and qzit, if performed, or else the identity matrix. C if matz has been set to .false., z is not referenced. C C on output C C a has been reduced further to a quasi-triangular matrix C in which all nonzero subdiagonal elements correspond to C pairs of complex eigenvalues. C C b is still in upper triangular form, although its elements C have been altered. b(n,1) is unaltered. C C alfr and alfi contain the real and imaginary parts of the C diagonal elements of the triangular matrix that would be C obtained if a were reduced completely to triangular form C by unitary transformations. non-zero values of alfi occur C in pairs, the first member positive and the second negative. C C beta contains the diagonal elements of the corresponding b, C normalized to be real and non-negative. the generalized C eigenvalues are then the ratios ((alfr+i*alfi)/beta). C C z contains the product of the right hand transformations C (for all three steps) if matz has been set to .true. C C questions and comments should be directed to burton s. garbow, C mathematics and computer science div, argonne national laboratory C C this version dated august 1983. C C ------------------------------------------------------------------ C X EPSB=B(N,1) X ISW=1 C .......... find eigenvalues of quasi-triangular matrices. C for en=n step -1 until 1 do -- .......... X DO 260 NN=1,N X EN=N+1-NN X NA=EN-1 X IF (ISW.EQ.2) GO TO 250 X IF (EN.EQ.1) GO TO 10 X IF (A(EN,NA).NE.0.0D0) GO TO 20 C .......... 1-by-1 block, one real root .......... X 10 ALFR(EN)=A(EN,EN) X IF (B(EN,EN).LT.0.0D0) ALFR(EN)=-ALFR(EN) X BETA(EN)=DABS(B(EN,EN)) X ALFI(EN)=0.0D0 X GO TO 260 C .......... 2-by-2 block .......... X 20 IF (DABS(B(NA,NA)).LE.EPSB) GO TO 100 X IF (DABS(B(EN,EN)).GT.EPSB) GO TO 30 X A1=A(EN,EN) X A2=A(EN,NA) X BN=0.0D0 X GO TO 60 X 30 AN=DABS(A(NA,NA))+DABS(A(NA,EN))+DABS(A(EN,NA))+DABS(A(EN,EN)) X BN=DABS(B(NA,NA))+DABS(B(NA,EN))+DABS(B(EN,EN)) X A11=A(NA,NA)/AN X A12=A(NA,EN)/AN X A21=A(EN,NA)/AN X A22=A(EN,EN)/AN X B11=B(NA,NA)/BN X B12=B(NA,EN)/BN X B22=B(EN,EN)/BN X E=A11/B11 X EI=A22/B22 X S=A21/(B11*B22) X T=(A22-E*B22)/B22 X IF (DABS(E).LE.DABS(EI)) GO TO 40 X E=EI X T=(A11-E*B11)/B11 X 40 C=0.5D0*(T-S*B12) X D=C*C+S*(A12-E*B12) X IF (D.LT.0.0D0) GO TO 140 C .......... two real roots. C zero both a(en,na) and b(en,na) .......... X E=E+(C+DSIGN(DSQRT(D),C)) X A11=A11-E*B11 X A12=A12-E*B12 X A22=A22-E*B22 X IF (DABS(A11)+DABS(A12).LT.DABS(A21)+DABS(A22)) GO TO 50 X A1=A12 X A2=A11 X GO TO 60 X 50 A1=A22 X A2=A21 C .......... choose and apply real z .......... X 60 S=DABS(A1)+DABS(A2) X U1=A1/S X U2=A2/S X R=DSIGN(DSQRT(U1*U1+U2*U2),U1) X V1=-(U1+R)/R X V2=-U2/R X U2=V2/V1 C X DO 70 I=1,EN X T=A(I,EN)+U2*A(I,NA) X A(I,EN)=A(I,EN)+T*V1 X A(I,NA)=A(I,NA)+T*V2 X T=B(I,EN)+U2*B(I,NA) X B(I,EN)=B(I,EN)+T*V1 X B(I,NA)=B(I,NA)+T*V2 X 70 CONTINUE C X IF (.NOT.MATZ) GO TO 90 C X DO 80 I=1,N X T=Z(I,EN)+U2*Z(I,NA) X Z(I,EN)=Z(I,EN)+T*V1 X Z(I,NA)=Z(I,NA)+T*V2 X 80 CONTINUE C X 90 IF (BN.EQ.0.0D0) GO TO 130 X IF (AN.LT.DABS(E)*BN) GO TO 100 X A1=B(NA,NA) X A2=B(EN,NA) X GO TO 110 X 100 A1=A(NA,NA) X A2=A(EN,NA) C .......... choose and apply real q .......... X 110 S=DABS(A1)+DABS(A2) X IF (S.EQ.0.0D0) GO TO 130 X U1=A1/S X U2=A2/S X R=DSIGN(DSQRT(U1*U1+U2*U2),U1) X V1=-(U1+R)/R X V2=-U2/R X U2=V2/V1 C X DO 120 J=NA,N X T=A(NA,J)+U2*A(EN,J) X A(NA,J)=A(NA,J)+T*V1 X A(EN,J)=A(EN,J)+T*V2 X T=B(NA,J)+U2*B(EN,J) X B(NA,J)=B(NA,J)+T*V1 X B(EN,J)=B(EN,J)+T*V2 X 120 CONTINUE C X 130 A(EN,NA)=0.0D0 X B(EN,NA)=0.0D0 X ALFR(NA)=A(NA,NA) X ALFR(EN)=A(EN,EN) X IF (B(NA,NA).LT.0.0D0) ALFR(NA)=-ALFR(NA) X IF (B(EN,EN).LT.0.0D0) ALFR(EN)=-ALFR(EN) X BETA(NA)=DABS(B(NA,NA)) X BETA(EN)=DABS(B(EN,EN)) X ALFI(EN)=0.0D0 X ALFI(NA)=0.0D0 X GO TO 250 C .......... two complex roots .......... X 140 E=E+C X EI=DSQRT(-D) X A11R=A11-E*B11 X A11I=EI*B11 X A12R=A12-E*B12 X A12I=EI*B12 X A22R=A22-E*B22 X A22I=EI*B22 X IF (DABS(A11R)+DABS(A11I)+DABS(A12R)+DABS(A12I).LT.DABS(A21)+ X $ DABS(A22R)+DABS(A22I)) GO TO 150 X A1=A12R X A1I=A12I X A2=-A11R X A2I=-A11I X GO TO 160 X 150 A1=A22R X A1I=A22I X A2=-A21 X A2I=0.0D0 C .......... choose complex z .......... X 160 CZ=DSQRT(A1*A1+A1I*A1I) X IF (CZ.EQ.0.0D0) GO TO 170 X SZR=(A1*A2+A1I*A2I)/CZ X SZI=(A1*A2I-A1I*A2)/CZ X R=DSQRT(CZ*CZ+SZR*SZR+SZI*SZI) X CZ=CZ/R X SZR=SZR/R X SZI=SZI/R X GO TO 180 X 170 SZR=1.0D0 X SZI=0.0D0 X 180 IF (AN.LT.(DABS(E)+EI)*BN) GO TO 190 X A1=CZ*B11+SZR*B12 X A1I=SZI*B12 X A2=SZR*B22 X A2I=SZI*B22 X GO TO 200 X 190 A1=CZ*A11+SZR*A12 X A1I=SZI*A12 X A2=CZ*A21+SZR*A22 X A2I=SZI*A22 C .......... choose complex q .......... X 200 CQ=DSQRT(A1*A1+A1I*A1I) X IF (CQ.EQ.0.0D0) GO TO 210 X SQR=(A1*A2+A1I*A2I)/CQ X SQI=(A1*A2I-A1I*A2)/CQ X R=DSQRT(CQ*CQ+SQR*SQR+SQI*SQI) X CQ=CQ/R X SQR=SQR/R X SQI=SQI/R X GO TO 220 X 210 SQR=1.0D0 X SQI=0.0D0 C .......... compute diagonal elements that would result C if transformations were applied .......... X 220 SSR=SQR*SZR+SQI*SZI X SSI=SQR*SZI-SQI*SZR X I=1 X TR=CQ*CZ*A11+CQ*SZR*A12+SQR*CZ*A21+SSR*A22 X TI=CQ*SZI*A12-SQI*CZ*A21+SSI*A22 X DR=CQ*CZ*B11+CQ*SZR*B12+SSR*B22 X DI=CQ*SZI*B12+SSI*B22 X GO TO 240 X 230 I=2 X TR=SSR*A11-SQR*CZ*A12-CQ*SZR*A21+CQ*CZ*A22 X TI=-SSI*A11-SQI*CZ*A12+CQ*SZI*A21 X DR=SSR*B11-SQR*CZ*B12+CQ*CZ*B22 X DI=-SSI*B11-SQI*CZ*B12 X 240 T=TI*DR-TR*DI X J=NA X IF (T.LT.0.0D0) J=EN X R=DSQRT(DR*DR+DI*DI) X BETA(J)=BN*R X ALFR(J)=AN*(TR*DR+TI*DI)/R X ALFI(J)=AN*T/R X IF (I.EQ.1) GO TO 230 X 250 ISW=3-ISW X 260 CONTINUE X B(N,1)=EPSB C X RETURN X END C C********************************************************************** SHAR_EOF chmod 0600 dble/sup/eispack.f || echo 'restore of dble/sup/eispack.f failed' Wc_c="`wc -c < 'dble/sup/eispack.f'`" test 38090 -eq "$Wc_c" || echo 'dble/sup/eispack.f: original size 38090, current size' "$Wc_c" fi # ============= dble/sup/makefile ============== if test -f 'dble/sup/makefile' -a X"$1" != X"-c"; then echo 'x - skipping dble/sup/makefile (File already exists)' else echo 'x - extracting dble/sup/makefile (Text)' sed 's/^X//' << 'SHAR_EOF' > 'dble/sup/makefile' && #********************************************************************** # # Copyright (C) 1991 Noel M. Nachtigal # All rights reserved. # # This code is part of a copyrighted package. For details, see the # file `cpyrit.doc' in the current directory. # # ***************************************************************** # ANY USE OF THIS CODE CONSTITUES ACCEPTANCE OF THE TERMS OF THE # COPYRIGHT NOTICE # ***************************************************************** # #********************************************************************** # # Makefile for the support subdirectory. # # Files in this directory: # FOR = OBJ = eispack.o linpack.o support.o SRC = eispack.f linpack.f support.f X # # Include here the skeleton makefile. # include ../skeleton.mak include ../local.mak X # # This is the local help target. # lochelp: X # # Dependencies for files in this directory. # eispack.o: eispack.f X linpack.o: linpack.f X support.o: support.f SHAR_EOF chmod 0600 dble/sup/makefile || echo 'restore of dble/sup/makefile failed' Wc_c="`wc -c < 'dble/sup/makefile'`" test 1016 -eq "$Wc_c" || echo 'dble/sup/makefile: original size 1016, current size' "$Wc_c" fi exit 0