C ALGORITHM 782, COLLECTED ALGORITHMS FROM ACM. C THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, C VOL. 24,NO. 2, June, 1998, P. 254--257. #! /bin/sh # This is a shell archive, meaning: # 1. Remove everything above the #! /bin/sh line. # 2. Save the resulting text in a file. # 3. Execute the file with /bin/sh (not csh) to create the files: # rrqr_acm/ # rrqr_acm/README # rrqr_acm/cv15.acm/ # rrqr_acm/cv15.acm/GenCode # rrqr_acm/cv15.acm/Makefile.GenCode # rrqr_acm/cv15.acm/cgeqpb.f # rrqr_acm/cv15.acm/cgeqpc.f # rrqr_acm/cv15.acm/cgeqpw.f # rrqr_acm/cv15.acm/cgeqpx.f # rrqr_acm/cv15.acm/cgeqpy.f # rrqr_acm/cv15.acm/clasmx.f # rrqr_acm/cv15.acm/clauc1.f # rrqr_acm/cv15.acm/cmylap.f # rrqr_acm/cv15.acm/ctrqpx.f # rrqr_acm/cv15.acm/ctrqpy.f # rrqr_acm/cv15.acm/ctrqxc.f # rrqr_acm/cv15.acm/ctrqyc.f # rrqr_acm/cv15.acm/ctrrnk.f # rrqr_acm/cv15.acm/zgeqpb.f # rrqr_acm/cv15.acm/zgeqpc.f # rrqr_acm/cv15.acm/zgeqpw.f # rrqr_acm/cv15.acm/zgeqpx.f # rrqr_acm/cv15.acm/zgeqpy.f # rrqr_acm/cv15.acm/zlasmx.f # rrqr_acm/cv15.acm/zlauc1.f # rrqr_acm/cv15.acm/zmylap.f # rrqr_acm/cv15.acm/ztrqpx.f # rrqr_acm/cv15.acm/ztrqpy.f # rrqr_acm/cv15.acm/ztrqxc.f # rrqr_acm/cv15.acm/ztrqyc.f # rrqr_acm/cv15.acm/ztrrnk.f # rrqr_acm/generate # rrqr_acm/lib/ # rrqr_acm/lib/Makefile # rrqr_acm/matgen/ # rrqr_acm/matgen/Makefile # rrqr_acm/matgen/clagge.f # rrqr_acm/matgen/claghe.f # rrqr_acm/matgen/clagsy.f # rrqr_acm/matgen/clarge.f # rrqr_acm/matgen/clarnd.f # rrqr_acm/matgen/claror.f # rrqr_acm/matgen/clarot.f # rrqr_acm/matgen/clatm1.f # rrqr_acm/matgen/clatm2.f # rrqr_acm/matgen/clatm3.f # rrqr_acm/matgen/clatme.f # rrqr_acm/matgen/clatmr.f # rrqr_acm/matgen/clatms.f # rrqr_acm/matgen/dlagge.f # rrqr_acm/matgen/dlagsy.f # rrqr_acm/matgen/dlaran.f # rrqr_acm/matgen/dlarge.f # rrqr_acm/matgen/dlarnd.f # rrqr_acm/matgen/dlaror.f # rrqr_acm/matgen/dlarot.f # rrqr_acm/matgen/dlatm1.f # rrqr_acm/matgen/dlatm2.f # rrqr_acm/matgen/dlatm3.f # rrqr_acm/matgen/dlatme.f # rrqr_acm/matgen/dlatmr.f # rrqr_acm/matgen/dlatms.f # rrqr_acm/matgen/slagge.f # rrqr_acm/matgen/slagsy.f # rrqr_acm/matgen/slaran.f # rrqr_acm/matgen/slarge.f # rrqr_acm/matgen/slarnd.f # rrqr_acm/matgen/slaror.f # rrqr_acm/matgen/slarot.f # rrqr_acm/matgen/slatm1.f # rrqr_acm/matgen/slatm2.f # rrqr_acm/matgen/slatm3.f # rrqr_acm/matgen/slatme.f # rrqr_acm/matgen/slatmr.f # rrqr_acm/matgen/slatms.f # rrqr_acm/matgen/zlagge.f # rrqr_acm/matgen/zlaghe.f # rrqr_acm/matgen/zlagsy.f # rrqr_acm/matgen/zlarge.f # rrqr_acm/matgen/zlarnd.f # rrqr_acm/matgen/zlaror.f # rrqr_acm/matgen/zlarot.f # rrqr_acm/matgen/zlatm1.f # rrqr_acm/matgen/zlatm2.f # rrqr_acm/matgen/zlatm3.f # rrqr_acm/matgen/zlatme.f # rrqr_acm/matgen/zlatmr.f # rrqr_acm/matgen/zlatms.f # rrqr_acm/testing/ # rrqr_acm/testing/ctest.lg.in # rrqr_acm/testing/ctest.me.in # rrqr_acm/testing/ctest.sm.in # rrqr_acm/testing/dtest.lg.in # rrqr_acm/testing/dtest.me.in # rrqr_acm/testing/dtest.sm.in # rrqr_acm/testing/stest.lg.in # rrqr_acm/testing/stest.me.in # rrqr_acm/testing/stest.sm.in # rrqr_acm/testing/testall # rrqr_acm/testing/testall.lg # rrqr_acm/testing/testall.me # rrqr_acm/testing/testall.sm # rrqr_acm/testing/v2/ # rrqr_acm/testing/v2/GenCode # rrqr_acm/testing/v2/Makefile # rrqr_acm/testing/v2/Makefile.GenCode # rrqr_acm/testing/v2/aladhd.f # rrqr_acm/testing/v2/alaerh.f # rrqr_acm/testing/v2/alaesm.f # rrqr_acm/testing/v2/alahd.f # rrqr_acm/testing/v2/alareq.f # rrqr_acm/testing/v2/alasum.f # rrqr_acm/testing/v2/alasvm.f # rrqr_acm/testing/v2/cchkaa.f # rrqr_acm/testing/v2/cchkqp.f # rrqr_acm/testing/v2/cchkrr.f # rrqr_acm/testing/v2/cerrqp.f # rrqr_acm/testing/v2/cerrrr.f # rrqr_acm/testing/v2/chkxer.f # rrqr_acm/testing/v2/cqpt01.f # rrqr_acm/testing/v2/cqrt11.f # rrqr_acm/testing/v2/cqrt12.f # rrqr_acm/testing/v2/crrt01.f # rrqr_acm/testing/v2/crrt02.f # rrqr_acm/testing/v2/dchkaa.f # rrqr_acm/testing/v2/dchkqp.f # rrqr_acm/testing/v2/dchkrr.f # rrqr_acm/testing/v2/derrqp.f # rrqr_acm/testing/v2/derrrr.f # rrqr_acm/testing/v2/dlaord.f # rrqr_acm/testing/v2/dqpt01.f # rrqr_acm/testing/v2/dqrt11.f # rrqr_acm/testing/v2/dqrt12.f # rrqr_acm/testing/v2/drrt01.f # rrqr_acm/testing/v2/drrt02.f # rrqr_acm/testing/v2/ilaenv.f # rrqr_acm/testing/v2/schkaa.f # rrqr_acm/testing/v2/schkqp.f # rrqr_acm/testing/v2/schkrr.f # rrqr_acm/testing/v2/serrqp.f # rrqr_acm/testing/v2/serrrr.f # rrqr_acm/testing/v2/slaord.f # rrqr_acm/testing/v2/sqpt01.f # rrqr_acm/testing/v2/sqrt11.f # rrqr_acm/testing/v2/sqrt12.f # rrqr_acm/testing/v2/srrt01.f # rrqr_acm/testing/v2/srrt02.f # rrqr_acm/testing/v2/xerbla.f # rrqr_acm/testing/v2/xlaenv.f # rrqr_acm/testing/v2/zchkaa.f # rrqr_acm/testing/v2/zchkqp.f # rrqr_acm/testing/v2/zchkrr.f # rrqr_acm/testing/v2/zerrqp.f # rrqr_acm/testing/v2/zerrrr.f # rrqr_acm/testing/v2/zqpt01.f # rrqr_acm/testing/v2/zqrt11.f # rrqr_acm/testing/v2/zqrt12.f # rrqr_acm/testing/v2/zrrt01.f # rrqr_acm/testing/v2/zrrt02.f # rrqr_acm/testing/ztest.lg.in # rrqr_acm/testing/ztest.me.in # rrqr_acm/testing/ztest.sm.in # rrqr_acm/timing/ # rrqr_acm/timing/ctime.lg.in # rrqr_acm/timing/ctime.me.in # rrqr_acm/timing/ctime.sm.in # rrqr_acm/timing/dtime.lg.in # rrqr_acm/timing/dtime.me.in # rrqr_acm/timing/dtime.sm.in # rrqr_acm/timing/stime.lg.in # rrqr_acm/timing/stime.me.in # rrqr_acm/timing/stime.sm.in # rrqr_acm/timing/timeall # rrqr_acm/timing/v2/ # rrqr_acm/timing/v2/GenCode # rrqr_acm/timing/v2/Makefile # rrqr_acm/timing/v2/Makefile.GenCode # rrqr_acm/timing/v2/atimck.f # rrqr_acm/timing/v2/atimin.f # rrqr_acm/timing/v2/ctimaa.f # rrqr_acm/timing/v2/ctimmg.f # rrqr_acm/timing/v2/ctimmm.f # rrqr_acm/timing/v2/ctimmv.f # rrqr_acm/timing/v2/ctimqp.f # rrqr_acm/timing/v2/ctimqr.f # rrqr_acm/timing/v2/ctimrr.f # rrqr_acm/timing/v2/dmflop.f # rrqr_acm/timing/v2/dopbl2.f # rrqr_acm/timing/v2/dopbl3.f # rrqr_acm/timing/v2/dopla.f # rrqr_acm/timing/v2/dprtb4.f # rrqr_acm/timing/v2/dprtb5.f # rrqr_acm/timing/v2/dprtbl.f # rrqr_acm/timing/v2/dtimaa.f # rrqr_acm/timing/v2/dtimmg.f # rrqr_acm/timing/v2/dtimmm.f # rrqr_acm/timing/v2/dtimmv.f # rrqr_acm/timing/v2/dtimqp.f # rrqr_acm/timing/v2/dtimqr.f # rrqr_acm/timing/v2/dtimrr.f # rrqr_acm/timing/v2/icopy.f # rrqr_acm/timing/v2/ilaenv.f # rrqr_acm/timing/v2/smflop.f # rrqr_acm/timing/v2/sopbl2.f # rrqr_acm/timing/v2/sopbl3.f # rrqr_acm/timing/v2/sopla.f # rrqr_acm/timing/v2/sprtb4.f # rrqr_acm/timing/v2/sprtb5.f # rrqr_acm/timing/v2/sprtbl.f # rrqr_acm/timing/v2/stimaa.f # rrqr_acm/timing/v2/stimmg.f # rrqr_acm/timing/v2/stimmm.f # rrqr_acm/timing/v2/stimmv.f # rrqr_acm/timing/v2/stimqp.f # rrqr_acm/timing/v2/stimqr.f # rrqr_acm/timing/v2/stimrr.f # rrqr_acm/timing/v2/xlaenv.f # rrqr_acm/timing/v2/ztimaa.f # rrqr_acm/timing/v2/ztimmg.f # rrqr_acm/timing/v2/ztimmm.f # rrqr_acm/timing/v2/ztimmv.f # rrqr_acm/timing/v2/ztimqp.f # rrqr_acm/timing/v2/ztimqr.f # rrqr_acm/timing/v2/ztimrr.f # rrqr_acm/timing/ztime.lg.in # rrqr_acm/timing/ztime.me.in # rrqr_acm/timing/ztime.sm.in # rrqr_acm/v15.acm/ # rrqr_acm/v15.acm/Dqr.in # rrqr_acm/v15.acm/GenCode # rrqr_acm/v15.acm/Makefile # rrqr_acm/v15.acm/Makefile.GenCode # rrqr_acm/v15.acm/README # rrqr_acm/v15.acm/REVISIONS # rrqr_acm/v15.acm/Sqr.in # rrqr_acm/v15.acm/c # rrqr_acm/v15.acm/compile # rrqr_acm/v15.acm/dgeqpb.f # rrqr_acm/v15.acm/dgeqpc.f # rrqr_acm/v15.acm/dgeqpw.f # rrqr_acm/v15.acm/dgeqpx.f # rrqr_acm/v15.acm/dgeqpy.f # rrqr_acm/v15.acm/dgntst.f # rrqr_acm/v15.acm/dlasmx.f # rrqr_acm/v15.acm/dlauc1.f # rrqr_acm/v15.acm/dmylap.f # rrqr_acm/v15.acm/dqr.f # rrqr_acm/v15.acm/dqrmtx.f # rrqr_acm/v15.acm/dtrqpx.f # rrqr_acm/v15.acm/dtrqpy.f # rrqr_acm/v15.acm/dtrqxc.f # rrqr_acm/v15.acm/dtrqyc.f # rrqr_acm/v15.acm/dtrrnk.f # rrqr_acm/v15.acm/dutils.f # rrqr_acm/v15.acm/esm.f # rrqr_acm/v15.acm/ilaenv.f # rrqr_acm/v15.acm/sgeqpb.f # rrqr_acm/v15.acm/sgeqpc.f # rrqr_acm/v15.acm/sgeqpw.f # rrqr_acm/v15.acm/sgeqpx.f # rrqr_acm/v15.acm/sgeqpy.f # rrqr_acm/v15.acm/sgntst.f # rrqr_acm/v15.acm/slasmx.f # rrqr_acm/v15.acm/slauc1.f # rrqr_acm/v15.acm/smylap.f # rrqr_acm/v15.acm/sqr.f # rrqr_acm/v15.acm/sqrmtx.f # rrqr_acm/v15.acm/strqpx.f # rrqr_acm/v15.acm/strqpy.f # rrqr_acm/v15.acm/strqxc.f # rrqr_acm/v15.acm/strqyc.f # rrqr_acm/v15.acm/strrnk.f # rrqr_acm/v15.acm/sutils.f # This archive created: Tue Jan 19 19:19:54 1999 export PATH; PATH=/bin:$PATH if test ! -d 'rrqr_acm' then mkdir 'rrqr_acm' fi cd 'rrqr_acm' if test -f 'README' then echo shar: will not over-write existing file "'README'" else cat << SHAR_EOF > 'README' ******************************************************************************* * * * RRQR Factorization * * "Codes for Rank-Revealing Factorizations of Dense Matrices" * * by C.H.Bischof and G.Quintana-Orti. * * * ******************************************************************************* * RELEASE: 1.0.5 (5-Jan-1997) * ******************************************************************************* Requirements: ============= To use these codes, both LAPACK and BLAS libraries are strictly necessary and must be correctly installed in the target machine. In addition, tuned BLAS libraries are strongly recommended to obtain optimal performance. Contents of the distribution file: ================================== The distribution file, named "rrqr_acm.tar.gz", contains all the directories and files needed for creating, testing and timings the new RRQR codes. The untaring of the file "rrqr_acm.tar.gz" creates the directory "rrqr_acm" in the current directory. All the other directories and files needed are created inside "rrqr_acm". So this file must be moved to the final position before installing it. Two steps are needed to uncompress and untar the code: 1. Uncompressing the file: gunzip rrqr_acm.tar.gz 2. Untaring the files and directories: tar xf rrqr_acm.tar Once uncompressed and untared, the directory "rrqr_acm" appears in the current directory. It will contain 6 subdirectories: lib: This directory contain the tool to create the RRQR object library. testing: This directory contains the drivers to test REAL, DOUBLE PRECISION, COMPLEX and COMPLEX*16 RRQR code. timing: This directory contains the drivers to get the timings for REAL, DOUBLE PRECISION, COMPLEX and COMPLEX*16 RRQR code. v15.acm: This directory contains the latest version of the REAL RRQR code. Besides, it contains a complete testing/timing driver for the RRQR code. This is the one used to get the timings shown in the paper. cv15.acm: This directory contains the latest version of the COMPLEX RRQR code. matgen: This directory is only needed if library "tmglib.a" is not installed. The library "tmglib.a" (timing library) is the timing library that comes with the LAPACK installation package. It contains some interesting matrix generators needed by both our testing and timing codes. If the library "tmglib.a" is already installed in your target machine, you can remove this directory. If you do not have this library, you can build it from this directory. To continue the installation, jump to "rrqr_acm" directory: cd rrqr_acm Steps to build the RRQR library: ================================ 1. Go to "lib" directory: cd lib 2. Edit the file "Makefile" and set the two macros FORTRAN and OPTS according to your system requirements. You can find this macros at the very beginning of the file. For example, on SUN the macros should be set to: FORTRAN = f77 # Fortran-77 compiler command. OPTS = -O # Fortran-77 compiler optimizing options. You might need to set other macros such as RANLIB, AR, etc. Ask your system administrator about these ones (usually well known in UNIX environments). 3. Type "make" to build the library for the four data-types: single, double, complex and complex*16. If not all the data-types are needed, type: "make single" to build the library for only REAL code, "make double" to build the library for only DOUBLE PRECISION code, "make complex" to build the library for only COMPLEX code, or "make complex*16" to build the library for only COMPLEX*16 code, or whatever combination you need, such as "make single complex", etc. This step will build the object files and the library. The object files are left in the directory "rrqr_acm/lib". The library is left in the directory "rrqr_acm" (the parent of directory "lib"), so as to allow an easy access from the testing and timing drivers. Steps to build the testing drivers: =================================== 1. Go to the testing directory: cd testing/v2 2. Edit the file "Makefile" and set the macros accordingly to your system. The macros you must set are the following: FORTRAN, OPTS, LOADER, LOADOPTS, LAPACKLIB, TMGLIB, and BLASLIB. You can find them at the very beginning of this file. For example, on SUN the macros should be set to: FORTRAN = f77 # Fortran-77 compiler command. OPTS = -O # Fortran-77 compiler optimizing options. LOADER = f77 # Fortran-77 linker command. LOADOPTS = -O # Fortran-77 linker optimizing options. LAPACKLIB = /usr/lib/lapack.a # Path of LAPACK library. TMGLIB = /usr/lib/tmglib.a # Path of TMGLIB library. BLASLIB = /usr/lib/blas.a # Path of BLAS library. You may need to ask your system administrator the paths of lapack, tmglib, and blas libraries. 3. The command "make" will make the testing programs for the four data-types: REAL, DOUBLE PRECISION, COMPLEX and COMPLEX*16. If not all the data-types are needed, type: "make single" to build the library for only REAL code, "make double" to build the library for only DOUBLE PRECISION code, "make complex" to build the library for only COMPLEX code, or "make complex*16" to build the library for only COMPLEX*16 code, or whatever combination you need, such as "make single complex", etc. The executable files are created in the directory "testing". 4. Now you can start the tests. If you want to perform some complete tests on you machine, just type "testall". This script performs some thorough and long tests for the four data types on three sets of matrices: small (files _test.sm.in), medium (files _test.me.in), and large (files _test.lg.in). In this case, the results will be placed in files _test.sm.out, _test.me.out and _test.lg.out. To perform some specific tests, you must type: xlintst_ < _test.in where _ must be replaced by s, d, c, or z, according to the data types you want to test. The input files (such as _test.in) tells the driver which matrix sizes, matrix blocks, matrix types, etc. to test. You can find many examples of input files in directory "testing": "stest.sm.in" is an input file to perform some small tests on single precision real numbers. "dtest.me.in" is an input file to perform some medium tests on double precision real numbers. "ctest.lg.in" is an input file to perform some large tests on single precision complex numbers.g etc. Note: Be careful with matrix sizes. If you are going to test big matrices, you must set the parameters of files "xchkaa.f" accordingly. The current drivers are prepared to test up to 500x500 matrices. If you want to test larger ones, you must change the definition of NMAX in the mentioned files. Steps to build the timing drivers: ================================== 1. Go to the timing directory: "cd timing/v2" 2. Edit the file "Makefile" and set the macros accordingly to your system. The macros you must set are the following: FORTRAN, OPTS, LOADER, LOADOPTS, LAPACKLIB, TMGLIB, and BLASLIB. You can find them at the very beginning of this file. For example, on SUN the macros should be set to: FORTRAN = f77 # Fortran-77 compiler command. OPTS = -O # Fortran-77 compiler optimizing options. LOADER = f77 # Fortran-77 linker command. LOADOPTS = -O # Fortran-77 linker optimizing options. LAPACKLIB = /usr/lib/lapack.a # Path of LAPACK library. TMGLIB = /usr/lib/tmglib.a # Path of TMGLIB library. BLASLIB = /usr/lib/blas.a # Path of BLAS library. You may need to ask your system administrator the paths of lapack, tmglib, and blas libraries. 3. The command "make" will make the timing programs for the four data-types. If not all the data-types are needed, type: "make single" to build the library for only REAL code, "make double" to build the library for only DOUBLE PRECISION code, "make complex" to build the library for only COMPLEX code, or "make complex*16" to build the library for only COMPLEX*16 code, or whatever combination you need, such as "make single complex", etc. The executable files are created in "timing" directory. 4. Now you can start the timings. If you want to perform some complete timings on you machine, just type "timeall". This script performs some thorough and long timings for the four data types on three sets of matrices: small (files _time.sm.in), medium (files _time.me.in), and large (files _time.lg.in). In this case, the results will be placed in files _time.sm.out, _time.me.out and _time.lg.out. To perform some specific timings, you must type: xlintim_ < _time.in where _ must be replaced by s, d, c, or z, according to the data types you want to test. The input files (such as _time.in) tells the driver which matrix sizes, matrix blocks, matrix types, etc. to test. You can find many examples of input files in directory "timing": "stime.sm.in" is an input file to perform some small timings on single precision real numbers. "dtime.me.in" is an input file to perform some medium timings on double precision real numbers. "ctime.lg.in" is an input file to perform some large timings on single precision complex numbers.g etc. Note: Be careful with matrix sizes. If you are going to test big matrices, you must set the parameters of files "xtimaa.f" accordingly. The current drivers are prepared to test up to 1001x1001 matrices. If you want to test larger ones, you must change the definition of NMAX in the mentioned files. Drivers in v15.acm: =================== 1. Go to the directory "v15.acm": "cd v15.acm" 2. Edit the file "Makefile" and set the macros accordingly to your system. The macros you must set are the following: P, FORTRAN, OPTS, LOADER, LOADOPTS, LAPACKLIB, TMGLIB, and BLASLIB. You can find them at the very beginning of this file. For example, on SUN the macros should be set to: P = s # Precision (s or d). FORTRAN = f77 # Fortran-77 compiler command. OPTS = -O # Fortran-77 compiler optimizing options. LOADER = f77 # Fortran-77 linker command. LOADOPTS = -O # Fortran-77 linker optimizing options. LAPACKLIB = /usr/lib/lapack.a # Path of LAPACK library. TMGLIB = /usr/lib/tmglib.a # Path of TMGLIB library. BLASLIB = /usr/lib/blas.a # Path of BLAS library. You may need to ask your system administrator the paths of lapack, tmglib, and blas libraries. 3. The command "make" will make the timing programs for data type specified in the makefile (s for single precision and d for double precision). The name of the executables are "sqr" for single precision and "dqr" for double precision. The executable files are created in the same directory. 4. Now you can start the timings. To perform some specific timings, you must type: sqr (for single precision), and dqr (for double precision). File "sqr" is controlled by the input file "Sqr.in" and file "dqr" is controlled by the input file "Dqr.in". These two "*.in" files specify the matrix sizes, block sizes, minimum time to benchmark, and other information to use during the execution. You can find examples of input files in directory "v15.acm". In this case, the name of the output file is composed of "time" plus a suffix named in the first line of the input file. Note: Be careful with matrix sizes. If you are going to test big matrices, you must set the parameters of files "xtimaa.f" accordingly. The current drivers are prepared to test up to 1001x1001 matrices. If you want to test larger ones, you must change the definition of NMAX in the mentioned files. Steps to build the matrix generator: ==================================== 1. Go to the matrix generating directory: "cd matgen" 2. Edit the file "Makefile" and set the macros FORTRAN and OPTS according to your system requirements. For example, on SUN the macros should be set to: FORTRAN = f77 # Fortran-77 compiler command. OPTS = -O # Fortran-77 compiler optimizing options. You might need to set other macros such as RANLIB, AR, etc. Ask your system administrator about these ones (usually well known in UNIX environments). 3. The command "make" will make the timing programs for the four data-types. If not all the data-types are needed, type: "make single" to build the library for only REAL code, "make double" to build the library for only DOUBLE PRECISION code, "make complex" to build the library for only COMPLEX code, or "make complex*16" to build the library for only COMPLEX*16 code, or whatever combination you need, such as "make single complex", etc. Known problems: =============== We have detected that IBM ESSL library can produce residuals a bit larger than usual when testing the code on 500x500 matrices. We have also checked that the residuals go back under the usual threshold when using the BLAS library obtained from Netlib, which can be obtained with LAPACK distribution. Subroutine xBDSQR from LAPACK 2.0 seems to have an error. The same subroutine from LAPACK 1.0b is working fine. This subroutine computes the singular value decomposition of a bidiagonal matrix. This bug have affected our drivers in directory "v15.acm" by showing in a few cases big residuals in the comparison of the singular values of A and R. In case of problems: ==================== You can send e-mail to: gquintan@dsic.upv.es gquintan@inf.uji.es SHAR_EOF fi # end of overwriting check if test ! -d 'cv15.acm' then mkdir 'cv15.acm' fi cd 'cv15.acm' if test -f 'GenCode' then echo shar: will not over-write existing file "'GenCode'" else cat << SHAR_EOF > 'GenCode' make source -f Makefile.GenCode SHAR_EOF fi # end of overwriting check if test -f 'Makefile.GenCode' then echo shar: will not over-write existing file "'Makefile.GenCode'" else cat << SHAR_EOF > 'Makefile.GenCode' ####################################################################### # # Makefile for generating COMPLEX single and double precision source. # # Authors: C.H.Bischof and G.Quintana-Orti # ####################################################################### ####################################################################### # # The user must set this options: # REAL_SOURCES = ../../v15 COMPLEX_SOURCES = ../../cv15 GENERATE = ../generate CPP = /lib/cpp CPPFLAGS = "-I$(REAL_SOURCES)" # ####################################################################### ####################################################################### # # Modules for Rank-Revealing QR: # C_RRQR_MODULES = \ cgeqpb.f cgeqpw.f cgeqpc.f \ cgeqpx.f ctrqpx.f ctrqxc.f \ cgeqpy.f ctrqpy.f ctrqyc.f \ ctrrnk.f clauc1.f clasmx.f \ cmylap.f Z_RRQR_MODULES = \ zgeqpb.f zgeqpw.f zgeqpc.f \ zgeqpx.f ztrqpx.f ztrqxc.f \ zgeqpy.f ztrqpy.f ztrqyc.f \ ztrrnk.f zlauc1.f zlasmx.f \ zmylap.f # # ####################################################################### source: complex complex16 complex: $(C_RRQR_MODULES) complex16: $(Z_RRQR_MODULES) clean: - rm -f *.f # # Rules for the source modules of RRQR. # cgeqpb.f: $(COMPLEX_SOURCES)/ygeqpb.F $(GENERATE) c $(COMPLEX_SOURCES)/ygeqpb.F $@ $(CPP) $(CPPFLAGS) cgeqpw.f: $(COMPLEX_SOURCES)/ygeqpw.F $(GENERATE) c $(COMPLEX_SOURCES)/ygeqpw.F $@ $(CPP) $(CPPFLAGS) cgeqpc.f: $(COMPLEX_SOURCES)/ygeqpc.F $(GENERATE) c $(COMPLEX_SOURCES)/ygeqpc.F $@ $(CPP) $(CPPFLAGS) cgeqpx.f: $(COMPLEX_SOURCES)/ygeqpx.F $(GENERATE) c $(COMPLEX_SOURCES)/ygeqpx.F $@ $(CPP) $(CPPFLAGS) ctrqpx.f: $(COMPLEX_SOURCES)/ytrqpx.F $(GENERATE) c $(COMPLEX_SOURCES)/ytrqpx.F $@ $(CPP) $(CPPFLAGS) ctrqxc.f: $(COMPLEX_SOURCES)/ytrqxc.F $(GENERATE) c $(COMPLEX_SOURCES)/ytrqxc.F $@ $(CPP) $(CPPFLAGS) cgeqpy.f: $(COMPLEX_SOURCES)/ygeqpy.F $(GENERATE) c $(COMPLEX_SOURCES)/ygeqpy.F $@ $(CPP) $(CPPFLAGS) ctrqpy.f: $(COMPLEX_SOURCES)/ytrqpy.F $(GENERATE) c $(COMPLEX_SOURCES)/ytrqpy.F $@ $(CPP) $(CPPFLAGS) ctrqyc.f: $(COMPLEX_SOURCES)/ytrqyc.F $(GENERATE) c $(COMPLEX_SOURCES)/ytrqyc.F $@ $(CPP) $(CPPFLAGS) ctrrnk.f: $(COMPLEX_SOURCES)/ytrrnk.F $(GENERATE) c $(COMPLEX_SOURCES)/ytrrnk.F $@ $(CPP) $(CPPFLAGS) clauc1.f: $(COMPLEX_SOURCES)/ylauc1.F $(GENERATE) c $(COMPLEX_SOURCES)/ylauc1.F $@ $(CPP) $(CPPFLAGS) clasmx.f: $(COMPLEX_SOURCES)/ylasmx.F $(GENERATE) c $(COMPLEX_SOURCES)/ylasmx.F $@ $(CPP) $(CPPFLAGS) cmylap.f: $(COMPLEX_SOURCES)/cmylap.f cp $(COMPLEX_SOURCES)/cmylap.f . zgeqpb.f: $(COMPLEX_SOURCES)/ygeqpb.F $(GENERATE) z $(COMPLEX_SOURCES)/ygeqpb.F $@ $(CPP) $(CPPFLAGS) zgeqpw.f: $(COMPLEX_SOURCES)/ygeqpw.F $(GENERATE) z $(COMPLEX_SOURCES)/ygeqpw.F $@ $(CPP) $(CPPFLAGS) zgeqpc.f: $(COMPLEX_SOURCES)/ygeqpc.F $(GENERATE) z $(COMPLEX_SOURCES)/ygeqpc.F $@ $(CPP) $(CPPFLAGS) zgeqpx.f: $(COMPLEX_SOURCES)/ygeqpx.F $(GENERATE) z $(COMPLEX_SOURCES)/ygeqpx.F $@ $(CPP) $(CPPFLAGS) ztrqpx.f: $(COMPLEX_SOURCES)/ytrqpx.F $(GENERATE) z $(COMPLEX_SOURCES)/ytrqpx.F $@ $(CPP) $(CPPFLAGS) ztrqxc.f: $(COMPLEX_SOURCES)/ytrqxc.F $(GENERATE) z $(COMPLEX_SOURCES)/ytrqxc.F $@ $(CPP) $(CPPFLAGS) zgeqpy.f: $(COMPLEX_SOURCES)/ygeqpy.F $(GENERATE) z $(COMPLEX_SOURCES)/ygeqpy.F $@ $(CPP) $(CPPFLAGS) ztrqpy.f: $(COMPLEX_SOURCES)/ytrqpy.F $(GENERATE) z $(COMPLEX_SOURCES)/ytrqpy.F $@ $(CPP) $(CPPFLAGS) ztrqyc.f: $(COMPLEX_SOURCES)/ytrqyc.F $(GENERATE) z $(COMPLEX_SOURCES)/ytrqyc.F $@ $(CPP) $(CPPFLAGS) ztrrnk.f: $(COMPLEX_SOURCES)/ytrrnk.F $(GENERATE) z $(COMPLEX_SOURCES)/ytrrnk.F $@ $(CPP) $(CPPFLAGS) zlauc1.f: $(COMPLEX_SOURCES)/ylauc1.F $(GENERATE) z $(COMPLEX_SOURCES)/ylauc1.F $@ $(CPP) $(CPPFLAGS) zlasmx.f: $(COMPLEX_SOURCES)/ylasmx.F $(GENERATE) z $(COMPLEX_SOURCES)/ylasmx.F $@ $(CPP) $(CPPFLAGS) zmylap.f: $(COMPLEX_SOURCES)/zmylap.f cp $(COMPLEX_SOURCES)/zmylap.f . SHAR_EOF fi # end of overwriting check if test -f 'cgeqpb.f' then echo shar: will not over-write existing file "'cgeqpb.f'" else cat << SHAR_EOF > 'cgeqpb.f' SUBROUTINE CGEQPB( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ IRCOND, ORCOND, RANK, SVLUES, WORK, LWORK, $ RWORK, INFO ) * * This code is part of a release of the package for computing * rank-revealing QR Factorizations written by: * ================================================================== * Christian H. Bischof and Gregorio Quintana-Orti * Math. and Comp. Sci. Div. Departamento de Informatica * Argonne National Lab. Universidad Jaime I * Argonne, IL 60439 Campus P. Roja, 12071 Castellon * USA Spain * bischof@mcs.anl.gov gquintan@inf.uji.es * ================================================================== * $Revision: 1.42 $ * $Date: 96/12/30 16:59:36 $ * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, RANK, LWORK, INFO REAL IRCOND, ORCOND * .. * .. Array Arguments .. INTEGER JPVT( * ) COMPLEX A( LDA, * ), C( LDC, * ), WORK( * ) REAL SVLUES( 4 ), RWORK( * ) * .. * * Purpose * ======= * * CGEQPB computes a QR factorization * A*P = Q*[ R11 R12 ] * [ 0 R22 ] * of a real m by n matrix A. The permutation P is * chosen with the goal to reveal the rank of A by a * suitably dimensioned trailing submatrix R22 with norm(R22) * being small. * * Arguments * ========= * * JOB (input) INTEGER * The job to do: * = 1: The transformations needed in the * triangularization are only applied to matrix A. * Thus, matrix C is not updated. * = 2: The same transformations needed in the * triangularization of matrix A are applied to * matrix C from the left. * That is, if Q'*A*P=R, then C := Q'*C. * In this case, matrix C is m-by-k. * = 3: The transpose of the transformations needed * in the triangularization of matrix A are applied * to matrix C from the right. * That is, if Q'*A*P=R, then C := C*Q. * In this case, matrix C is k-by-m. * In these three cases, the permutations are always saved * into vector JPVT. * * M (input) INTEGER * The number of rows of matrices A. M >= 0. * If JOB=2, M is the number of rows of matrix C. * If JOB=3, M is the number of columns of matrix C. * * N (input) INTEGER * The number of columns of matrix A. N >= 0. * * K (input) INTEGER * It defines the dimension of matrix C. K >= 0. * If JOB=2, K is the number of columns of matrix C. * If JOB=3, K is the number of rows of matrix C. * * A (input/output) COMPLEX array, dimension (LDA,N) * On entry, the m by n matrix A. * On exit, the upper triangle of the array contains the * min(m,n) by n upper trapezoidal matrix R; the lower triangle * array is filled with zeros. * * LDA (input) INTEGER * The leading dimension of array A. LDA >= MAX(1,M). * * C (input/output) COMPLEX array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the transformations * applied to matrix A are also applied to matrix C. * * LDC (input) INTEGER * The leading dimension of array C. * If JOB=2, then LDC >= MAX(1,M). * If JOB=3, then LDC >= MAX(1,K). * * JPVT (output) INTEGER array, dimension (N) * JPVT(I) = K <==> Column K of A has been permuted into * position I in AP. * JPVT(1:RANK) contains the indices of the columns considered * linearly independent. * JPVT(RANK+1:N) contains the indices of the columns considered * linearly dependent from the previous ones. * * IRCOND (input) FLOATING_DECLARE * 1/IRCOND specifies an upper bound on the condition number * of R11. If IRCOND == 0, IRCOND = machine precision is chosen * as default. IRCOND must be >= 0. * * ORCOND (output) FLOATING_DECLARE * 1/ORCOND is an estimate for the condition number of R11. * * RANK (output) INTEGER * RANK is an estimate for the numerical rank of A with respect * to the threshold 1/IRCOND in the sense that * RANK = arg_max(cond_no(R(1:r,1:r))<1/IRCOND) * This may be an underestimate of the rank if the leading * columns were not well-conditioned. * * SVLUES (output) REAL array, dimension (4) * On exit, SVLUES contains estimates of some of the * singular values of the triangular factor R. * SVLUES(1): largest singular value of R(1:RANK,1:RANK) * SVLUES(2): smallest singular value of R(1:RANK,1:RANK) * SVLUES(3): smallest singular value of R(1:RANK+1,1:RANK+1) * SVLUES(4): smallest singular value of R * If the triangular factorization is a rank-revealing one * (which will be the case if the leading columns were well- * conditioned), then SVLUES(1) will also be an estimate * for the largest singular value of A, SVLUES(2) and SVLUES(3) * will be estimates for the RANK-th and (RANK+1)-st singular * value of A, and SVLUES(4) will be an estimate for the * smallest singular value of A. * By examining these values, one can confirm that the rank is * well defined with respect to the threshold chosen. * * WORK (workspace) COMPLEX array, dimension (LWORK) * On exit: WORK(1) is the size of the storage array needed * for optimal performance * * LWORK (input) INTEGER * The dimension of array WORK. * If JOB=1: * The unblocked strategy requires that: * LWORK >= 2*MN+N. * The block algorithm requires that: * LWORK >= 2*MN+N*NB. * If JOB<>1: * The unblocked strategy requires that: * LWORK >= 2*MN+MAX(K,N). * The block algorithm requires that: * LWORK >= 2*MN+NB*NB+NB*MAX(K,N). * Where MN = min(M,N) and NB is the maximum of blocksize * used within xGEQRF and blocksize used within xUNMQR. * In both cases, the minimum required workspace is the * one for the unblocked strategy. * * RWORK (workspace) REAL array, dimension (2*N) * * INFO (output) INTEGER * = 0: Successful exit * < 0: If INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. REAL ZERO COMPLEX CZERO PARAMETER ( ZERO = 0.0E+0, CZERO = ( 0.0E+0, 0.0E+0 ) ) INTEGER INB, INBMIN, IXOVER PARAMETER ( INB = 1, INBMIN = 2, IXOVER = 3 ) * * Indices into the 'svlues' array. * INTEGER IMAX, IBEFOR, IAFTER, IMIN PARAMETER ( IMAX = 1, IBEFOR = 2, IAFTER = 3, IMIN = 4 ) * .. * .. Local Scalars .. INTEGER I, J, MN, ITEMP, KK, LACPTD, MVIDX, STREJ, $ ACCPTD, NB, LWSIZE, NLLITY, KB, WSIZE, WKMIN REAL SMIN, MXNM, RCOND LOGICAL BLOCK * .. * .. External Subroutines .. EXTERNAL XERBLA, CGEQPC, CGEQPW, $ CLARFT, CLARFB * .. * .. External Functions .. INTEGER ILAENV REAL SLAMCH, SLASMX EXTERNAL ILAENV, SLAMCH, SLASMX * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN, REAL, INT * .. * .. Executable Statements .. * MN = MIN( M, N ) * * Compute the minimum required complex workspace. * IF( JOB.EQ.1 ) THEN WKMIN = 2*MN + N ELSE WKMIN = 2*MN + MAX( N, K ) END IF * * Test input arguments * ==================== * INFO = 0 IF( ( JOB.LT.1 ).OR.( JOB.GT.3 ) ) THEN INFO = -1 ELSE IF( M.LT.0 ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( K.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -6 ELSE IF( ( ( JOB.EQ.1 ).AND.( LDC.LT.1 ) ).OR. $ ( ( JOB.EQ.2 ).AND.( LDC.LT.MAX( 1, M ) ) ).OR. $ ( ( JOB.EQ.3 ).AND.( LDC.LT.MAX( 1, K ) ) ) ) THEN INFO = -8 ELSE IF( IRCOND.LT.ZERO ) THEN INFO = -10 ELSE IF( LWORK.LT.MAX( 1, WKMIN ) ) THEN INFO = -15 END IF IF( ( INFO .EQ. 0 .OR. INFO .EQ. -15 ).AND. LWORK.GE.1 ) THEN * * Compute the optimal complex workspace. * IF( JOB.EQ.1 ) THEN NB = ILAENV( INB, 'CGEQRF', ' ', M, N, 0, 0 ) WSIZE = 2*MN + MAX( 3*N, N*NB ) ELSE NB = MAX( ILAENV( INB, 'CGEQRF', ' ', M, N, 0, 0 ), $ ILAENV( INB, 'CUNMQR', ' ', M, N, 0, 0 ) ) WSIZE = MAX( 2*MN + MAX( N, K ), $ 2*MN + NB*NB + NB*MAX( N, K ) ) END IF WORK( 1 ) = REAL( WSIZE ) END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGEQPB', -INFO ) RETURN END IF * * Initialization of vector JPVT. * DO 70 J = 1, N JPVT( J ) = J 70 CONTINUE * * Quick return if possible * IF( MN.EQ.0 ) THEN RANK = 0 ORCOND = ZERO SVLUES( IMAX ) = ZERO SVLUES( IBEFOR ) = ZERO SVLUES( IAFTER ) = ZERO SVLUES( IMIN ) = ZERO RETURN END IF * * Check whether Threshold for condition number was supplied. * If not, choose machine precision as default for RCOND. * IF( IRCOND.GT.ZERO ) THEN RCOND = IRCOND ELSE RCOND = SLAMCH( 'Epsilon' ) END IF * * Determine block size and whether to use blocked code at all * IF( LWORK.LT.WSIZE ) THEN IF( JOB.EQ.1 ) THEN NB = ( LWORK-2*MN )/N ELSE ITEMP = INT( SQRT( REAL( $ MAX( K, N )**2+4*LWORK-8*MN ) ) ) NB = ( ITEMP-MAX( K, N ) )/2 END IF END IF * BLOCK = ( ( NB.GT.1 ).AND. $ ( NB.GE.ILAENV( INBMIN, 'CGEQRF', ' ', M, N, 0, 0 ) ).AND. $ ( MN.GE.ILAENV( IXOVER, 'CGEQRF', ' ', M, N, 0, 0 ) ) ) * * The size of the pivot window is chosen to be NB + NLLITY * for the blocked algorithm. * NLLITY = MIN( MN, MAX( 10, NB/2+(N*5)/100 ) ) * * *************************************************** * * Move column with largest residual norm up front * * *************************************************** * CALL CGEQPC( JOB, M, N, K, A, LDA, C, LDC, 1, 0, $ RCOND, LACPTD, JPVT, WORK( 1 ), WORK( MN+1 ), $ SVLUES, MXNM, WORK( 2*MN+1 ), LWORK-2*MN, RWORK ) IF( LACPTD.EQ.1 ) THEN IF( LACPTD.EQ.MN ) THEN RANK = 1 ORCOND = SVLUES( IBEFOR )/SVLUES( IMAX ) GOTO 30 ELSE SMIN = SVLUES( IBEFOR ) END IF ELSE RANK = 0 ORCOND = ZERO SVLUES( IMAX ) = ZERO SVLUES( IBEFOR ) = ZERO SVLUES( IAFTER ) = ZERO SVLUES( IMIN ) = ZERO GOTO 30 END IF * * **************************** * * Factor remaining columns * * **************************** * IF( BLOCK ) THEN * * *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* * * Using blocked code with restricted pivoting strategy * * *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* * STREJ = N+1 KK = 2 * 10 IF( ( KK.GE.STREJ ).OR.( KK.GT.MN ) ) GOTO 20 * * invariant: A(:,KK) is the first column in currently * considered block column. * KB = MIN( NB, MIN( MN+1, STREJ )-KK ) * * The goal now is to find "KB" independent columns * among the remaining STREJ-KK not yet rejected columns. * LWSIZE = MIN( STREJ-KK, KB+NLLITY ) CALL CGEQPW( M, LWSIZE, KB, KK-1, LACPTD, A, LDA, JPVT, $ RCOND, WORK( MN+1 ), SMIN, MXNM, $ WORK( 1 ), WORK( 2*MN+1 ), RWORK ) IF( LACPTD.GT.0 ) THEN * * Accumulate Householder vectors in a block reflector. * CALL CLARFT( 'Forward', 'Columnwise', M-KK+1, $ LACPTD, A( KK, KK ), LDA, WORK( KK ), $ WORK( 2*MN+1 ), LACPTD ) * * Apply block reflector to A(KK:M,KK+LWSIZE:N). * IF( ( KK+LWSIZE ).LE.N ) THEN CALL CLARFB( 'Left', 'Conjugate Transpose', $ 'Forward', 'Columnwise', $ M-KK+1, N-KK-LWSIZE+1, LACPTD, $ A( KK, KK ), LDA, $ WORK( 2*MN+1 ), LACPTD, $ A( KK, KK+LWSIZE ), LDA, $ WORK( 2*MN+LACPTD*LACPTD+1 ), $ N-KK-LWSIZE+1 ) END IF * * Apply block reflector to the corresponding part * of matrix C. * IF( ( JOB.EQ.2 ).AND.( K.GT.0 ) ) THEN * * Apply it to matrix C(KK:M,1:K) from the left. * CALL CLARFB( 'Left', 'Conjugate Transpose', $ 'Forward', 'Columnwise', M-KK+1, K, $ LACPTD, A( KK, KK ), LDA, $ WORK( 2*MN+1 ), LACPTD, $ C( KK, 1 ), LDC, $ WORK( 2*MN+LACPTD*LACPTD+1 ), K ) ELSE IF( ( JOB.EQ.3 ).AND.( K.GT.0 ) ) THEN * * Apply the transpose of it to matrix C(1:K,KK:M) * from the right. * CALL CLARFB( 'Right', 'No Transpose', 'Forward', $ 'Columnwise', K, M-KK+1, LACPTD, $ A( KK, KK ), LDA, $ WORK( 2*MN+1 ), LACPTD, $ C( 1, KK ), LDC, $ WORK( 2*MN+LACPTD*LACPTD+1 ), K ) END IF END IF * * Move rejected columns to the end if there is space. * IF( LACPTD.LT.KB ) THEN IF( STREJ.LE.( KK+LWSIZE ) ) THEN STREJ = KK + LACPTD ELSE MVIDX = STREJ DO 40 I = KK+LACPTD, $ MIN( KK+LWSIZE-1, STREJ-LWSIZE+LACPTD-1 ) MVIDX = MVIDX - 1 CALL CSWAP( M, A( 1, I ),1, A( 1, MVIDX ),1 ) ITEMP = JPVT( I ) JPVT( I ) = JPVT( MVIDX ) JPVT( MVIDX ) = ITEMP 40 CONTINUE STREJ = MVIDX END IF END IF KK = KK + LACPTD GOTO 10 20 CONTINUE ACCPTD = KK-1 SVLUES( IMAX ) = SLASMX( ACCPTD )*MXNM SVLUES( IBEFOR ) = SMIN IF( ACCPTD.LT.MN ) THEN * * Process rejected columns. * CALL CGEQPC( JOB, M, N, K, A, LDA, C, LDC, MN-KK+1, $ KK-1, RCOND, LACPTD, JPVT, WORK( 1 ), $ WORK( MN+1 ), SVLUES, MXNM, WORK( 2*MN+1 ), $ LWORK-2*MN, RWORK ) RANK = ACCPTD + LACPTD ELSE RANK = ACCPTD SVLUES( IAFTER ) = SMIN SVLUES( IMIN ) = SMIN END IF ELSE * * *-*-*-*-*-*-*-*-*-*-*-*-* * * using unblocked code * * *-*-*-*-*-*-*-*-*-*-*-*-* * ACCPTD = 1 CALL CGEQPC( JOB, M, N, K, A, LDA, C, LDC, MN-ACCPTD, $ ACCPTD, RCOND, LACPTD, JPVT, WORK( 1 ), $ WORK( MN+1 ), SVLUES, MXNM, WORK( 2*MN+1 ), $ LWORK-2*MN, RWORK ) RANK = ACCPTD+LACPTD * END IF ORCOND = SVLUES( IBEFOR )/SVLUES( IMAX ) * * Nullify the lower part of matrix A. * 30 CONTINUE DO 50 J = 1, MN DO 60 I = J+1, M A( I, J ) = CZERO 60 CONTINUE 50 CONTINUE * WORK( 1 ) = REAL( WSIZE ) RETURN * * End of CGEQPB * END SHAR_EOF fi # end of overwriting check if test -f 'cgeqpc.f' then echo shar: will not over-write existing file "'cgeqpc.f'" else cat << SHAR_EOF > 'cgeqpc.f' SUBROUTINE CGEQPC( JOB, M, N, K, A, LDA, C, LDC, DSRD, OFFSET, $ IRCOND, LACPTD, JPVT, TAU, X, SVLUES, MXNM, $ WORK, LWORK, RWORK ) * * This code is part of a release of the package for computing * rank-revealing QR Factorizations written by: * ================================================================== * Christian H. Bischof and Gregorio Quintana-Orti * Math. and Comp. Sci. Div. Departamento de Informatica * Argonne National Lab. Universidad Jaime I * Argonne, IL 60439 Campus P. Roja, 12071 Castellon * USA Spain * bischof@mcs.anl.gov gquintan@inf.uji.es * ================================================================== * $Revision: 1.42 $ * $Date: 96/12/30 16:59:37 $ * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, DSRD, OFFSET, LACPTD, $ LWORK REAL IRCOND, MXNM * .. * .. Array Arguments .. INTEGER JPVT( * ) COMPLEX A( LDA, * ), C( LDC, * ), TAU( * ), $ WORK( * ), X( * ) REAL SVLUES( 4 ), RWORK( * ) * .. * * Purpose: * ======= * * CGEQPC continues a partial QR factorization of A. If * A(1:OFFSET,1:OFFSET) has been reduced to upper triangular * form, then SGQPC applies the traditional column pivoting * strategy to identify DSRD more independent columns of A with * the restriction that the condition number of the leading * triangle of A should not be larger than 1/IRCOND. If * LACPTD ( <= DSRD) such columns are found, then the condition * number of * A(1:OFFSET+LACPTD,1:OFFSET+LACPTD) is less than 1/IRCOND. * If LACPTD < DSRD, then the QR factorization of A is completed, * otherwise only DSRD new steps were performed. * * Arguments: * ========= * * JOB (input) INTEGER * The job to do: * = 1: The transformations needed in the * triangularization are only applied to matrix A. * Thus, matrix C is not updated. * = 2: The same transformations needed in the * triangularization of matrix A are applied to * matrix C from the left. * That is, if Q'*A*P=R, then C := Q'*C. * In this case, matrix C is m-by-k. * = 3: The transpose of the transformations needed * in the triangularization of matrix A are applied * to matrix C from the right. * That is, if Q'*A*P=R, then C := C*Q. * In this case, matrix C is k-by-m. * In these three cases, the permutations are always saved * into vector JPVT. * * M (input) INTEGER * The number of rows of matrices A. M >= 0. * If JOB=2, M is the number of rows of matrix C. * If JOB=3, M is the number of columns of matrix C. * * N (input) INTEGER * The number of columns of matrix A. N >= 0. * * K (input) INTEGER * It defines the dimension of matrix C. K >= 0. * If JOB=2, K is the number of columns of matrix C. * If JOB=3, K is the number of rows of matrix C. * * A (input/output) COMPLEX array, dimension (LDA,N) * On entry, the m by n matrix A. * On exit, the upper triangle of the array contains the * min(m,n) by n upper trapezoidal matrix R; the lower triangle * array is filled with zeros. * * LDA (input) INTEGER * The leading dimension of array A. LDA >= max(1,M). * * C (input/output) COMPLEX array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the transformations * applied to matrix A are also applied to matrix C. * * LDC (input) INTEGER * The leading dimension of array C. * If JOB=2, then LDC >= MAX(1,M). * If JOB=3, then LDC >= MAX(1,K). * * DSRD (input) INTEGER * The number of independent columns one would like to * extract. * * OFFSET (input) INTEGER * A(1:OFFSET,1:OFFSET) has already been factored. * OFFSET >= 0. * * IRCOND (input) REAL * 1/IRCOND is threshold for condition number. * * LACPTD (output) INTEGER * The number of additional columns that were identified * as independent. * * JPVT (input/output) INTEGER array, dimension (N) * If JPVT(I) = K, then the Ith column of the permuted * A was the Kth column of the original A. * * TAU (input/output) COMPLEX array, dimension (MIN(M,N)) * Further details of the matrix Q (see A). * * X (input/output) COMPLEX array, dimension (MIN(M,N)) * On entry: X(1:OFFSET) contains an approximate smallest * left singular vector of A(1:OFFSET,1:OFFSET) * On exit: X(1:OFFSET+LACPTD) contains an approximate * smallest left singular vector of * A(1:OFFSET+LACPTD,1:OFFSET+LACPTD). * * SVLUES (input/output) REAL array, dimension(4) * estimates of singular values. * On entry: SVLUES(1) = sigma_max(A(1:M,1:N)) * SVLUES(2) = sigma_min(A(1:OFFSET,1:OFFSET)) * On exit: SVLUES(1) = sigma_max(A(1:M,1:N)) * SVLUES(2) = sigma_r(B) * SVLUES(3) = sigma_(min(r+1,min(m,n)))(B) * SVLUES(4) = sigma_min(A) * where r = OFFSET+LACPTD and B = A(1:r,1:r) * * MXNM (input/output) FLOATING_DECLARE * On entry: norm of largest column in A(1:OFFSET,1:OFFSET) * On exit: norm of largest column in * A(1:J,1:J) where J = OFFSET+LACPTD * * WORK (workspace) FLOATING_DECLARE array, dimension (LWORK) * * LWORK (input) INTEGER * MAX( 1, N*NB ) if JOB=1, or * MAX( 1, MAX( N, K )*NB ) otherwise. * where NB is the maximum of blocksize used within xGEQRF and * blocksize used within xUNMQR. * * RWORK (workspace) REAL array, dimension ( 2*N ). * * Further Details * =============== * * The matrix Q is represented as a product of elementary reflectors * * Q = H(1) H(2) . . . H(n) * * Each H(i) has the form * * H = I - tau * v * v' * * where tau is a complex scalar, and v is a complex vector with * v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i). * * The matrix P is represented in jpvt as follows: If * jpvt(j) = i * then the jth column of P is the ith canonical unit vector. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE COMPLEX CONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, $ CONE = ( 1.0E+0, 0.0E+0 ) ) * * Indices into the 'svlues' array. * INTEGER IMAX, IBEFOR, IAFTER, IMIN PARAMETER ( IMAX = 1, IBEFOR = 2, IAFTER = 3, IMIN = 4 ) * .. * .. Local Scalars .. INTEGER I, J, PVT, MN, ITEMP, INFO, LASTI REAL TEMP, TEMP2, SMIN, SMINPR, SMAX, SMAXPR COMPLEX AII, SINE, COSINE * .. * .. External Subroutines .. EXTERNAL CLARFG, CLARF, CSWAP, CSCAL, $ CLAIC1, CGEQRF, CUNMQR * .. * .. External Functions .. INTEGER ISAMAX REAL SCNRM2, SLASMX LOGICAL CLAUC1 EXTERNAL ISAMAX, SCNRM2, SLASMX, CLAUC1 * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, CONJG * .. * .. Executable Statements .. * MN = MIN( M, N ) LACPTD = 0 IF( OFFSET.GT.0 ) THEN SMAX = SVLUES( IMAX ) SMIN = SVLUES( IBEFOR ) END IF * * Initialize partial column norms. The first n entries of * work store the exact column norms. * DO 10 I = OFFSET+1,N RWORK( I ) = SCNRM2( M-OFFSET, A( OFFSET+1, I ), 1 ) RWORK( N+I ) = RWORK( I ) 10 CONTINUE * * Compute factorization. * LASTI = MIN( MN, OFFSET+DSRD ) DO 20 I = OFFSET+1, LASTI * * Determine ith pivot column and swap if necessary. * PVT = ( I-1 )+ISAMAX( N-I+1, RWORK( I ), 1 ) IF( PVT.NE.I ) THEN CALL CSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 ) ITEMP = JPVT( PVT ) JPVT( PVT ) = JPVT( I ) JPVT( I ) = ITEMP RWORK( PVT ) = RWORK( I ) RWORK( N+PVT ) = RWORK( N+I ) END IF * * Generate elementary reflector H(i). * IF( I.LT.M ) THEN CALL CLARFG( M-I+1, A( I, I ), A( I+1, I ), 1, $ TAU( I ) ) ELSE CALL CLARFG( 1, A( M, M ), A( M, M ), 1, TAU( M ) ) END IF * * Apply elementary reflector H(I) to the corresponding blocks * of matrices A and C. * AII = A( I, I ) A( I, I ) = CONE IF( I.LT.N ) THEN * * Apply H(I) to A(I:M,I+1:N) from the left. * CALL CLARF( 'Left', M-I+1, N-I, A( I, I ), 1, $ CONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK ) END IF IF( ( JOB.EQ.2 ).AND.( K.GT.0 ) ) THEN * * Apply H(I) to C(I:M,1:K) from the left. * CALL CLARF( 'Left', M-I+1, K, A( I, I ), 1, $ CONJG( TAU( I ) ), C( I, 1 ), LDC, WORK ) ELSE IF( ( JOB.EQ.3 ).AND.( K.GT.0 ) ) THEN * * Apply the transpose of H(I) to C(1:K,I:M) from the right. * CALL CLARF( 'Right', K, M-I+1, A( I, I ), 1, $ TAU( I ), C( 1, I ), LDC, WORK ) END IF A( I, I ) = AII * * Update partial column norms. * IF( I.LT.LASTI ) THEN DO 30 J = I+1, N IF( RWORK( J ).NE.ZERO ) THEN TEMP = ONE-( ABS( A( I, J ) )/RWORK( J ) )**2 TEMP = MAX( TEMP, ZERO ) TEMP2 = ONE+0.05*TEMP*( RWORK( J )/RWORK( N+J ) )**2 IF( TEMP2.EQ.ONE ) THEN RWORK( J ) = SCNRM2( M-I, A( I+1, J ), 1 ) RWORK( N+J ) = RWORK( J ) ELSE RWORK( J ) = RWORK( J )*SQRT( TEMP ) END IF END IF 30 CONTINUE END IF * * Check new column for independence. * IF( I.EQ.1 ) THEN MXNM = ABS( A( 1, 1 ) ) SMIN = MXNM SMAX = MXNM X( 1 ) = CONE IF( MXNM.GT.ZERO ) THEN LACPTD = 1 ELSE SVLUES( IAFTER ) = SMIN GOTO 50 END IF ELSE SMAXPR = SLASMX( I )*MXNM IF( CLAUC1( I, X, SMIN, A( 1, I ), A( I, I ), $ SMAXPR*IRCOND ) ) THEN * * Column accepted. * SMAX = SMAXPR LACPTD = LACPTD + 1 ELSE * * Column rejected. * GOTO 50 END IF END IF 20 CONTINUE 50 SVLUES( IMAX ) = SMAX SVLUES( IBEFOR ) = SMIN IF( LACPTD.EQ.DSRD ) THEN * * DSRD independent columns have been found. * SVLUES( IAFTER ) = SMIN SVLUES( IMIN ) = SMIN ELSE * * All remaining columns rejected. * I = OFFSET + LACPTD + 1 IF( I.LT.MN ) THEN * * Factor remaining columns. * CALL CGEQRF( M-I, N-I, A( I+1, I+1 ), LDA, TAU( I+1 ), $ WORK, LWORK, INFO ) * * Apply the transformations computed in CGEQRF to the * corresponding part of matrix C. * IF( ( JOB.EQ.2 ).AND.( K.GT.0 ) ) THEN * * Apply them to C(I+1:M,1:K) from the left. * CALL CUNMQR( 'Left', 'Conjugate Transpose', $ M-I, K, MN-I, $ A( I+1, I+1 ), LDA, TAU( I+1 ), $ C( I+1, 1 ), LDC, WORK, LWORK, INFO ) ELSE IF( ( JOB.EQ.3 ).AND.( K.GT.0 ) ) THEN * * Apply the transpose of them to C(1:K,I+1:M) from the * right. * CALL CUNMQR( 'Right', 'No Transpose', K, M-I, MN-I, $ A( I+1, I+1 ), LDA, TAU( I+1 ), $ C( 1, I+1 ), LDC, WORK, LWORK, INFO ) END IF END IF * * Use incremental condition estimation to get an estimate * of the smallest singular value. * DO 60 I = MAX( 2, OFFSET+LACPTD+1 ), MN CALL CLAIC1( 2, I-1, X, SMIN, A( 1, I ), A( I, I ), $ SMINPR, SINE, COSINE ) CALL CSCAL( I-1, SINE, X, 1 ) X( I ) = COSINE SMIN = SMINPR IF( I.EQ.OFFSET+LACPTD+1 ) THEN SVLUES( IAFTER ) = SMIN END IF 60 CONTINUE SVLUES( IMIN ) = SMIN END IF RETURN * * End of CGEQPC * END SHAR_EOF fi # end of overwriting check if test -f 'cgeqpw.f' then echo shar: will not over-write existing file "'cgeqpw.f'" else cat << SHAR_EOF > 'cgeqpw.f' SUBROUTINE CGEQPW( M, LWSIZE, NB, OFFSET, LACPTD, A, LDA, JPVT, $ IRCOND, X, SMIN, MXNM, TAU, WORK, RWORK ) * * This code is part of a release of the package for computing * rank-revealing QR Factorizations written by: * ================================================================== * Christian H. Bischof and Gregorio Quintana-Orti * Math. and Comp. Sci. Div. Departamento de Informatica * Argonne National Lab. Universidad Jaime I * Argonne, IL 60439 Campus P. Roja, 12071 Castellon * USA Spain * bischof@mcs.anl.gov gquintan@inf.uji.es * ================================================================== * $Revision: 1.42 $ * $Date: 96/12/30 16:59:38 $ * * .. Scalar Arguments .. INTEGER M, LWSIZE, NB, OFFSET, LACPTD, LDA REAL IRCOND, SMIN, MXNM * .. * .. Array Arguments .. INTEGER JPVT( * ) COMPLEX A( LDA, * ), TAU( * ), X( * ), WORK( * ) REAL RWORK( * ) * * * Purpose * ======= * * CGEQPW applies one block step of the Householder QR * factorization algorithm with restricted pivoting. It is called * by CGEQPB to factorize a window of the matrix. * * Let A be the partial QR factorization of an M by (OFFSET+LWSIZE) * matrix C, i.e. we have computed an orthogonal matrix Q1 and a * permutation matrix P1 such that * C * P1 = Q1 * A * and A(:,1:OFFSET) is upper triangular. Let us denote A(:,1:OFFSET) * by B. Then in addition let * X be an approximate smallest left singular vector of B in the sense * that * sigma_min(B) ~ twonorm(B'*X) = SMIN * and * sigma_max(B) ~ ((offset)**(1./3.))*MXNM = SMAX * with * cond_no(B) ~ SMAX/SMIN <= 1/IRCOND * * Then CGEQP2 tries to identify NB columns in * A(:,OFFSET+1:OFFSET+LWSIZE) such that * cond_no([B,D]) < 1/IRCOND * where D are the KB columns of A(:,OFFSET+1:OFFSET+LWSIZE) that were * considered independent with respect to the threshold 1/IRCOND. * * On exit, * C * P2 = Q2 * A * is again a partial QR factorization of C, but columns * OFFSET+1:OFFSET+LACPTD of A have been reduced via * a series of elementary reflectors to upper * trapezoidal form. Further * sigma_min(A(:,1:OFFSET+LACPTD)) * ~ twonorm(A(:,1:OFFSET+LACPTD)'*x) = SMIN * and * sigma_max(A(:,1:OFFSET+LACPTD)) ~ sqrt(OFFSET+LACPTD)*MXNM = SMAX * with * cond_no(A(:,1:OFFSET+LACPTD)) * ~ SMAX/SMIN <= 1/IRCOND. * * In the ideal case, LACPTD = NB, that is, * we found NB independent columns in the window consisting of * the first LWSIZE columns of A. * * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. * * LWSIZE (input) INTEGER * The size of the pivot window in A. * * NB (input) INTEGER * The number of independent columns one would like to identify. * This equals the desired blocksize in CGEQPB. * * OFFSET (input) INTEGER * The number of rows and columns of A that need not be updated. * * LACPTD (output) INTEGER * The number of columns in A(:,OFFSET+LWSIZE) that were * accepted as linearly independent. * * A (input/output) COMPLEX array, dimension (LDA,OFFSET+LWSIZE) * On entry, the upper triangle of A(:,1:OFFSET) contains the * partially completed triangular factor R; the elements below * the diagonal, with the array TAU, represent the matrix Q1 as * a product of elementary reflectors. * On exit, the upper triangle of A(:,OFFSET+LACPTD) contains * the partially completed upper triangular factor R; the * elements below the diagonal, with the array TAU, represent * the matrix Q2 as a product of elementary reflectors. * A(OFFSET:M,LACPTD+1:LWSIZE) has been updated by the product * of these elementary reflectors. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= M. * * JPVT (input/output) INTEGER array, dimension (OFFSET+LWSIZE) * On entry and exit, jpvt(i) = k if the i-th column * of A was the k-th column of C. * * IRCOND (input) REAL * 1/IRCOND is the threshold for the condition number. * * X (input/output) COMPLEX array, dimension (OFFSET+NB) * On entry, X(1:OFFSET) is an approximate left nullvector of * the upper triangle of A(1:OFFSET,1:OFFSET). * On exit, X(1:OFFSET+LACPTD) is an approximate left * nullvector of the matrix in the upper triangle of * A(1:OFFSET+LACPTD,1:OFFSET+LACPTD). * * SMIN (input/output) REAL * On entry, SMIN is an estimate for the smallest singular * value of the upper triangle of A(1:OFFSET,1:OFFSET). * On exit, SMIN is an estimate for the smallest singular * value of the matrix in the upper triangle of * A(1:OFFSET+LACPTD,1:OFFSET+LACPTD). * * MXNM (input) FLOATING_DECLARE * The norm of the largest column in matrix A. * * TAU (output) COMPLEX array, dimension (OFFSET+LWSIZE) * On exit, TAU(1:OFFSET+LACPTD) contains details of * the matrix Q2. * * WORK (workspace) COMPLEX array, dimension (LWSIZE) * * RWORK (workspace) REAL array, dimension (2*LWSIZE) * * ================================================================ * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. INTEGER I, K, I1, PVTIDX, LASTK REAL TEMP, TEMP2, SMAX COMPLEX GAMMA, AKK * .. * .. External Subroutines .. EXTERNAL SCNRM2, CSCAL, CSWAP, CLARFG, $ CLARF, ISAMAX, CLAUC1, SLASMX INTEGER ISAMAX REAL SCNRM2, SLASMX LOGICAL CLAUC1 * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT, REAL, CMPLX, CONJG * .. * .. Executable Statements .. * * Initialize partial column norms (stored in the first LWSIZE * entries of WORK) and exact column norms (stored in the second * LWSIZE entries of WORK) for the first batch of columns. * DO 10 I = 1,LWSIZE RWORK( I ) = SCNRM2( M-OFFSET, A( OFFSET+1, OFFSET+I ), 1 ) RWORK( LWSIZE+I ) = RWORK( I ) 10 CONTINUE * * ************* * * Main loop * * ************* * LASTK = MIN( M, OFFSET+LWSIZE ) LACPTD = 0 1000 IF( LACPTD.EQ.NB ) GOTO 2000 * * Determine pivot candidate. * ========================= PVTIDX = OFFSET + LACPTD + $ ISAMAX( LWSIZE-LACPTD, RWORK( LACPTD+1 ), 1 ) K = OFFSET + LACPTD + 1 * * Exchange current column and pivot column. * IF( PVTIDX.NE.K ) THEN CALL CSWAP( M, A( 1, PVTIDX ), 1, A( 1, K ), 1 ) I1 = JPVT( PVTIDX ) JPVT( PVTIDX ) = JPVT( K ) JPVT( K ) = I1 TEMP = RWORK( PVTIDX-OFFSET ) RWORK( PVTIDX-OFFSET ) = RWORK( K-OFFSET ) RWORK( K-OFFSET ) = TEMP TEMP = RWORK( PVTIDX-OFFSET+LWSIZE ) RWORK( PVTIDX-OFFSET+LWSIZE ) = RWORK( K+LWSIZE-OFFSET ) RWORK( K+LWSIZE-OFFSET ) = TEMP END IF * * Determine (offset+lacptd+1)st diagonal element * GAMMA of matrix A should elementary reflector be applied. * TEMP = REAL( A( K, K ) ) IF( TEMP.EQ.ZERO ) THEN GAMMA = -RWORK( K-OFFSET ) ELSE GAMMA = -SIGN( RWORK( K-OFFSET ), TEMP ) END IF * * Update estimate for largest singular value. * SMAX = SLASMX( K )*MXNM * * Is candidate pivot column acceptable ? * ===================================== IF( CLAUC1( K, X, SMIN, A( 1, K ), GAMMA, SMAX*IRCOND ) ) $ THEN * * Pivot candidate was accepted. * ============================ * LACPTD = LACPTD + 1 * * Generate Householder vector. * IF( K.LT.M ) THEN CALL CLARFG( M-K+1, A( K, K ), A( K+1, K ), 1, $ TAU( K ) ) ELSE CALL CLARFG( 1, A( M, K), A( M, K ), 1, TAU ( K ) ) END IF * * Apply Householder reflection to A(k:m,k+1:lwsize). * IF( LACPTD.LT.LWSIZE ) THEN AKK = A( K, K ) A( K, K ) = CMPLX( ONE ) CALL CLARF( 'Left', M-K+1, LWSIZE-LACPTD, $ A( K, K ), 1, CONJG( TAU( K ) ), $ A( K, K+1 ), LDA, WORK ) A( K, K ) = AKK END IF * * Update partial column norms. * IF( K.LT.LASTK ) THEN DO 20 I = LACPTD+1,LWSIZE IF( RWORK( I ).NE.ZERO ) THEN TEMP = ONE- $ ( ABS( A( K, OFFSET+I ) )/RWORK( I ) )**2 TEMP = MAX( TEMP, ZERO ) TEMP2 = ONE+ 0.05*TEMP* $ ( RWORK( I )/RWORK( I+LWSIZE ) )**2 IF( TEMP2.EQ.ONE ) THEN RWORK( I ) = SCNRM2( M-K, $ A( K+1, OFFSET+I ), 1 ) RWORK( I+LWSIZE ) = RWORK( I ) ELSE RWORK( I ) = RWORK( I )*SQRT( TEMP ) END IF END IF 20 CONTINUE END IF ELSE * * Reject all remaining columns in pivot window. * ============================================ * GOTO 2000 END IF * * End while. * GOTO 1000 2000 CONTINUE RETURN * * End of CGEQPW * END SHAR_EOF fi # end of overwriting check if test -f 'cgeqpx.f' then echo shar: will not over-write existing file "'cgeqpx.f'" else cat << SHAR_EOF > 'cgeqpx.f' SUBROUTINE CGEQPX( JOB, M, N, K, A, LDA, C, LDC, JPVT, IRCOND, $ ORCOND, RANK, SVLUES, WORK, LWORK, RWORK, $ INFO ) * * This code is part of a release of the package for computing * rank-revealing QR Factorizations written by: * ================================================================== * Christian H. Bischof and Gregorio Quintana-Orti * Math. and Comp. Sci. Div. Departamento de Informatica * Argonne National Lab. Universidad Jaime I * Argonne, IL 60439 Campus P. Roja, 12071 Castellon * USA Spain * bischof@mcs.anl.gov gquintan@inf.uji.es * ================================================================== * $Revision: 1.42 $ * $Date: 96/12/30 16:59:38 $ * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, RANK, LWORK, INFO REAL IRCOND, ORCOND * .. * .. Array Arguments .. INTEGER JPVT( * ) COMPLEX A( LDA, * ), C( LDC, * ), WORK( * ) REAL SVLUES( 4 ), RWORK( * ) * .. * * Purpose * ======= * * CGEQPX computes a QR factorization * A*P = Q*[ R11 R12 ] * [ 0 R22 ] * of a real m by n matrix A. The permutation P is * chosen with the goal to reveal the rank of A by a * suitably dimensioned trailing submatrix R22 with norm(R22) * being small. * * Based on methods related to Chandrasekaran&Ipsen's algorithms. * * Arguments * ========= * * JOB (input) INTEGER * The job to do: * = 1: The transformations needed in the * triangularization are only applied to matrix A. * Thus, matrix C is not updated. * = 2: The same transformations needed in the * triangularization of matrix A are applied to * matrix C from the left. * That is, if Q'*A*P=R, then C := Q'*C. * In this case, matrix C is m-by-k. * = 3: The transpose of the transformations needed * in the triangularization of matrix A are applied * to matrix C from the right. * That is, if Q'*A*P=R, then C := C*Q. * In this case, matrix C is k-by-m. * In these three cases, the permutations are always saved * into vector JPVT. * * M (input) INTEGER * The number of rows of matrices A. M >= 0. * If JOB=2, M is the number of rows of matrix C. * If JOB=3, M is the number of columns of matrix C. * * N (input) INTEGER * The number of columns of matrix A. N >= 0. * * K (input) INTEGER * It defines the dimension of matrix C. K >= 0. * If JOB=2, K is the number of columns of matrix C. * If JOB=3, K is the number of rows of matrix C. * * A (input/output) COMPLEX array, dimension (LDA,N) * On entry, the m by n matrix A. * On exit, the upper triangle of the array contains the * min(m,n) by n upper trapezoidal matrix R; the lower triangle * array is filled with zeros. * * LDA (input) INTEGER * The leading dimension of array A. LDA >= MAX(1,M). * * C (input/output) COMPLEX array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the transformations * applied to matrix A are also applied to matrix C. * * LDC (input) INTEGER * The leading dimension of array C. * If JOB=2, then LDC >= MAX(1,M). * If JOB=3, then LDC >= MAX(1,K). * * JPVT (output) INTEGER array, dimension (N) * JPVT(I) = J <==> Column J of A has been permuted into * position I in AP. * JPVT(1:RANK) contains the indices of the columns considered * linearly independent. * JPVT(RANK+1:N) contains the indices of the columns considered * linearly dependent from the previous ones. * * IRCOND (input) FLOATING_DECLARE * 1/IRCOND specifies an upper bound on the condition number * of R11. If IRCOND == 0, IRCOND = machine precision is chosen * as default. IRCOND must be >= 0. * * ORCOND (output) FLOATING_DECLARE * 1/ORCOND is an estimate for the condition number of R11. * * RANK (output) INTEGER * RANK is an estimate for the numerical rank of A with respect * to the threshold 1/IRCOND in the sense that * RANK = arg_max(cond_no(R(1:r,1:r))<1/IRCOND) * * SVLUES (output) REAL array, dimension (4) * On exit, SVLUES contains estimates of some of the * singular values of the triangular factor R. * SVLUES(1): largest singular value of R(1:RANK,1:RANK) * SVLUES(2): smallest singular value of R(1:RANK,1:RANK) * SVLUES(3): smallest singular value of R(1:RANK+1,1:RANK+1) * SVLUES(4): smallest singular value of R * If the triangular factorization is a rank-revealing one * (which will be the case if the leading columns were well- * conditioned), then SVLUES(1) will also be an estimate * for the largest singular value of A, SVLUES(2) and SVLUES(3) * will be estimates for the RANK-th and (RANK+1)-st singular * value of A, and SVLUES(4) wil be an estimate for the * smallest singular value of A. * By examining these values, one can confirm that the rank is * well defined with respect to the threshold chosen. * * WORK (workspace) COMPLEX array, dimension (LWORK) * On exit: work(1) is the size of the storage array needed * for optimal performance * * LWORK (input) INTEGER * The dimension of array WORK. * If JOB=1: * The unblocked strategy requires that: * LWORK >= 2*MN+N. * The block algorithm requires that: * LWORK >= 2*MN+N*NB. * If JOB<>1: * The unblocked strategy requires that: * LWORK >= 2*MN+MAX(K,N). * The block algorithm requires that: * LWORK >= 2*MN+NB*NB+NB*MAX(K,N). * Where MN = min(M,N) and NB is the block size for this * environment. * In both cases, the minimum required workspace is the * one for the unblocked strategy. * * RWORK (workspace) REAL array, dimension ( 2*N ) * * INFO (output) INTEGER * = 0: Successful exit. * < 0: If INFO = -i, the i-th argument had an illegal value * > 0: Problems in the computation of the rank. * 1: Exceeded the allowed maximum number of steps. * 2: Rank not well defined. * In adition, vector SVLUES tell if rank is not well defined. * * ===================================================================== * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E+0 ) * .. * .. External Subroutines .. EXTERNAL XERBLA, CGEQPB, CTRQPX * .. * .. Intrinsic Functions .. INTRINSIC MIN, MAX, REAL * .. * .. Local Scalars .. REAL WSIZE INTEGER MN, WKMIN * .. * .. Executable Statements .. * MN = MIN( M, N ) IF( JOB.EQ.1 ) THEN WKMIN = 2*MN+N ELSE WKMIN = 2*MN+MAX(K,N) END IF * * Test input arguments * ==================== * INFO = 0 IF( ( JOB.LT.1 ).OR.( JOB.GT.3 ) ) THEN INFO = -1 ELSE IF( M.LT.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( K.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX(1,M) ) THEN INFO = -6 ELSE IF( ( ( JOB.EQ.1 ).AND.( LDC.LT.1 ) ).OR. $ ( ( JOB.EQ.2 ).AND.( LDC.LT.MAX( 1, M ) ) ).OR. $ ( ( JOB.EQ.3 ).AND.( LDC.LT.MAX( 1, K ) ) ) ) THEN INFO = -8 ELSE IF( IRCOND.LT.ZERO ) THEN INFO = -10 ELSE IF( LWORK.LT.MAX( 1, WKMIN ) ) THEN INFO = -15 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGEQPX',-INFO ) RETURN END IF * * Preprocessing * ============= * CALL CGEQPB( JOB, M, N, K, A, LDA, C, LDC, JPVT, IRCOND, $ ORCOND, RANK, SVLUES, WORK, LWORK, RWORK, INFO ) WSIZE = REAL( WORK( 1 ) ) * * Postprocessing * ============== * IF( RANK.GT.0 ) THEN CALL CTRQPX( JOB, M, N, K, A, LDA, C, LDC, JPVT, IRCOND, $ ORCOND, RANK, SVLUES, WORK, RWORK, INFO ) END IF * WORK( 1 ) = WSIZE RETURN * * End of CGEQPX * END SHAR_EOF fi # end of overwriting check if test -f 'cgeqpy.f' then echo shar: will not over-write existing file "'cgeqpy.f'" else cat << SHAR_EOF > 'cgeqpy.f' SUBROUTINE CGEQPY( JOB, M, N, K, A, LDA, C, LDC, JPVT, IRCOND, $ ORCOND, RANK, SVLUES, WORK, LWORK, RWORK, $ INFO ) * * This code is part of a release of the package for computing * rank-revealing QR Factorizations written by: * ================================================================== * Christian H. Bischof and Gregorio Quintana-Orti * Math. and Comp. Sci. Div. Departamento de Informatica * Argonne National Lab. Universidad Jaime I * Argonne, IL 60439 Campus P. Roja, 12071 Castellon * USA Spain * bischof@mcs.anl.gov gquintan@inf.uji.es * ================================================================== * $Revision: 1.42 $ * $Date: 96/12/30 16:59:40 $ * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, RANK, LWORK, INFO REAL IRCOND, ORCOND * .. * .. Array Arguments .. INTEGER JPVT( * ) COMPLEX A( LDA, * ), C( LDC, * ), WORK( * ) REAL SVLUES( 4 ), RWORK( * ) * .. * * Purpose * ======= * * CGEQPY computes a QR factorization * A*P = Q*[ R11 R12 ] * [ 0 R22 ] * of a real m by n matrix A. The permutation P is * chosen with the goal to reveal the rank of A by a * suitably dimensioned trailing submatrix R22 with norm(R22) * being small. * * Based on Pan&Tang's algorithm number 3. * * Arguments * ========= * * JOB (input) INTEGER * The job to do: * = 1: The transformations needed in the * triangularization are only applied to matrix A. * Thus, matrix C is not updated. * = 2: The same transformations needed in the * triangularization of matrix A are applied to * matrix C from the left. * That is, if Q'*A*P=R, then C := Q'*C. * In this case, matrix C is m-by-k. * = 3: The transpose of the transformations needed * in the triangularization of matrix A are applied * to matrix C from the right. * That is, if Q'*A*P=R, then C := C*Q. * In this case, matrix C is k-by-m. * In these three cases, the permutations are always saved * into vector JPVT. * * M (input) INTEGER * The number of rows of matrices A. M >= 0. * If JOB=2, M is the number of rows of matrix C. * If JOB=3, M is the number of columns of matrix C. * * N (input) INTEGER * The number of columns of matrix A. N >= 0. * * K (input) INTEGER * It defines the dimension of matrix C. K >= 0. * If JOB=2, K is the number of columns of matrix C. * If JOB=3, K is the number of rows of matrix C. * * A (input/output) COMPLEX array, dimension (LDA,N) * On entry, the m by n matrix A. * On exit, the upper triangle of the array contains the * min(m,n) by n upper trapezoidal matrix R; the lower triangle * array is filled with zeros. * * LDA (input) INTEGER * The leading dimension of array A. LDA >= MAX(1,M). * * C (input/output) COMPLEX array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the transformations * applied to matrix A are also applied to matrix C. * * LDC (input) INTEGER * The leading dimension of array C. * If JOB=2, then LDC >= MAX(1,M). * If JOB=3, then LDC >= MAX(1,K). * * JPVT (output) INTEGER array, dimension (N) * JPVT(I) = J <==> Column J of A has been permuted into * position I in AP. * JPVT(1:RANK) contains the indices of the columns considered * linearly independent. * JPVT(RANK+1:N) contains the indices of the columns considered * linearly dependent from the previous ones. * * IRCOND (input) FLOATING_DECLARE * 1/IRCOND specifies an upper bound on the condition number * of R11. If IRCOND == 0, IRCOND = machine precision is chosen * as default. IRCOND must be >= 0. * * ORCOND (output) FLOATING_DECLARE * 1/ORCOND is an estimate for the condition number of R11. * * RANK (output) INTEGER * RANK is an estimate for the numerical rank of A with respect * to the threshold 1/IRCOND in the sense that * RANK = arg_max(cond_no(R(1:r,1:r))<1/IRCOND) * * SVLUES (output) REAL array, dimension (4) * On exit, SVLUES contains estimates of some of the * singular values of the triangular factor R. * SVLUES(1): largest singular value of R(1:RANK,1:RANK) * SVLUES(2): smallest singular value of R(1:RANK,1:RANK) * SVLUES(3): smallest singular value of R(1:RANK+1,1:RANK+1) * SVLUES(4): smallest singular value of R * If the triangular factorization is a rank-revealing one * (which will be the case if the leading columns were well- * conditioned), then SVLUES(1) will also be an estimate * for the largest singular value of A, SVLUES(2) and SVLUES(3) * will be estimates for the RANK-th and (RANK+1)-st singular * value of A, and SVLUES(4) wil be an estimate for the * smallest singular value of A. * By examining these values, one can confirm that the rank is * well defined with respect to the threshold chosen. * * WORK (workspace) COMPLEX array, dimension (LWORK) * On exit: work(1) is the size of the storage array needed * for optimal performance * * LWORK (input) INTEGER * The dimension of array WORK. * If JOB=1: * The unblocked strategy requires that: * LWORK >= 2*MN+N. * The block algorithm requires that: * LWORK >= 2*MN+N*NB. * If JOB<>1: * The unblocked strategy requires that: * LWORK >= 2*MN+MAX(K,N). * The block algorithm requires that: * LWORK >= 2*MN+NB*NB+NB*MAX(K,N). * Where MN = min(M,N) and NB is the block size for this * environment. * In both cases, the minimum required workspace is the * one for the unblocked strategy. * * RWORK (workspace) REAL array, dimension ( 2*N ) * * INFO (output) INTEGER * = 0: Successful exit. * < 0: If INFO = -i, the i-th argument had an illegal value * > 0: Problems in the computation of the rank. * 1: Exceeded the allowed maximum number of steps. * 2: Rank not well defined. * In adition, vector SVLUES tell if rank is not well defined. * * ===================================================================== * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E+0 ) * .. * .. External Subroutines .. EXTERNAL XERBLA, CGEQPB, CTRQPY * .. * .. Intrinsic Functions .. INTRINSIC MIN, MAX, REAL * .. * .. Local Scalars .. REAL WSIZE INTEGER MN, WKMIN * .. * .. Executable Statements .. * MN = MIN( M, N ) IF( JOB.EQ.1 ) THEN WKMIN = 2*MN+N ELSE WKMIN = 2*MN+MAX(K,N) END IF * * Test input arguments * ==================== * INFO = 0 IF( ( JOB.LT.1 ).OR.( JOB.GT.3 ) ) THEN INFO = -1 ELSE IF( M.LT.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( K.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX(1,M) ) THEN INFO = -6 ELSE IF( ( ( JOB.EQ.1 ).AND.( LDC.LT.1 ) ).OR. $ ( ( JOB.EQ.2 ).AND.( LDC.LT.MAX( 1, M ) ) ).OR. $ ( ( JOB.EQ.3 ).AND.( LDC.LT.MAX( 1, K ) ) ) ) THEN INFO = -8 ELSE IF( IRCOND.LT.ZERO ) THEN INFO = -10 ELSE IF( LWORK.LT.MAX( 1, WKMIN ) ) THEN INFO = -15 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGEQPY',-INFO ) RETURN END IF * * Preprocessing * ============= * CALL CGEQPB( JOB, M, N, K, A, LDA, C, LDC, JPVT, IRCOND, $ ORCOND, RANK, SVLUES, WORK, LWORK, RWORK, INFO ) WSIZE = REAL( WORK( 1 ) ) * * Postprocessing * ============== * IF( RANK.GT.0 ) THEN CALL CTRQPY( JOB, M, N, K, A, LDA, C, LDC, JPVT, IRCOND, $ ORCOND, RANK, SVLUES, WORK, RWORK, INFO ) END IF * WORK( 1 ) = WSIZE RETURN * * End of CGEQPY * END SHAR_EOF fi # end of overwriting check if test -f 'clasmx.f' then echo shar: will not over-write existing file "'clasmx.f'" else cat << SHAR_EOF > 'clasmx.f' REAL FUNCTION SLASMX( I ) INTEGER I * REAL OTHIRD PARAMETER ( OTHIRD = 1.0E+0/3.0E+0 ) INTRINSIC REAL SLASMX = REAL( I )**OTHIRD RETURN END SHAR_EOF fi # end of overwriting check if test -f 'clauc1.f' then echo shar: will not over-write existing file "'clauc1.f'" else cat << SHAR_EOF > 'clauc1.f' LOGICAL FUNCTION CLAUC1( K, X, SMIN, W, GAMMA, THRESH ) * * This code is part of a release of the package for computing * rank-revealing QR Factorizations written by: * ================================================================== * Christian H. Bischof and Gregorio Quintana-Orti * Math. and Comp. Sci. Div. Departamento de Informatica * Argonne National Lab. Universidad Jaime I * Argonne, IL 60439 Campus P. Roja, 12071 Castellon * USA Spain * bischof@mcs.anl.gov gquintan@inf.uji.es * ================================================================== * $Revision: 1.42 $ * $Date: 96/12/30 16:59:41 $ * * .. Scalar Arguments .. INTEGER K REAL SMIN, THRESH COMPLEX GAMMA * .. * .. Array Arguments .. COMPLEX W( * ), X( * ) * .. * * Purpose * ======= * * PREC_LAUC1 applies incremental condition estimation to determine whether * the K-th column of A, stored in vector W, would be acceptable as a pivot * column with respect to the threshold THRESH. * * Arguments * ========= * * K (input) INTEGER * Length of vector X. * * X (input/output) COMPLEX array, dimension ( K ) * On entry, X(1:K-1) contains an approximate smallest left singular * vector of the upper triangle of A(1:k-1,1:k-1). * On exit, if CLAUC1 == .TRUE., X contains an approximate * smallest left singular vector of the upper triangle of A(1:k,1:k); * if CLAUC1 == .FALSE., X is unchanged. * * SMIN (input/output) REAL * On entry, an estimate for the smallest singular value of the * upper triangle of A(1:k-1,1:k-1). * On exit, if CLAUC1 == .TRUE., SMIN is an estimate of the * smallest singular value of the upper triangle of A(1:k,1:k); * if CLAUC1 == .FALSE., SMIN is unchanged. * * W (input) FLOATING_DECLARE array, dimension ( K-1 ) * The K-th column of matrix A excluding the diagonal element. * * GAMMA (input) COMPLEX * Diagonal entry in k-th column of A if column k were to * be accepted. * * THRESH (input) REAL * If the approximate smallest singular value for A(1:K,1:K) * is smaller than THRESH, the kth column is rejected. * * (CLAUC1) (output) LOGICAL * If the k-th column of A is found acceptable, CLAUC1 * returns .TRUE., otherwise it returns .FALSE. * * ===================================================================== * * .. Local Scalars .. REAL SMINPR COMPLEX SINE, COSINE * .. * .. External Subroutines .. EXTERNAL CLAIC1, CSCAL * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. Executable Statements .. * * * Try to use diagonal element as condition estimator * IF( THRESH.GT.ABS( GAMMA ) ) THEN CLAUC1 = .FALSE. RETURN END IF * * Use incremental condition estimation to determine an estimate * SMINPR and an approximate singular vector [SINE*X,COSINE]' * for A(K,K). * CALL CLAIC1( 2, K-1, X, SMIN, W, GAMMA, SMINPR, $ SINE, COSINE ) IF( THRESH.GT.SMINPR ) THEN CLAUC1 = .FALSE. ELSE CALL CSCAL( K-1, SINE, X, 1 ) X( K ) = COSINE SMIN = SMINPR CLAUC1 = .TRUE. END IF RETURN * * End of CLAUC1 * END SHAR_EOF fi # end of overwriting check if test -f 'cmylap.f' then echo shar: will not over-write existing file "'cmylap.f'" else cat << SHAR_EOF > 'cmylap.f' ********************************************************************* SUBROUTINE CGEQPF( M, N, A, LDA, JPVT, TAU, WORK, RWORK, INFO ) * * -- LAPACK auxiliary routine (version 1.0b) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. INTEGER JPVT( * ) REAL RWORK( * ) COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * CGEQPF computes a QR factorization with column pivoting of a * complex m by n matrix A: A*P = Q*R * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0 * * A (input/output) COMPLEX array, dimension (LDA,N) * On entry, the m by n matrix A. * On exit, the upper triangle of the array contains the * min(m,n) by n upper triangular matrix R; the elements * below the diagonal, together with the array TAU, * represent the orthogonal matrix Q as a product of * min(m,n) elementary reflectors. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * JPVT (input/output) INTEGER array, dimension (N) * on entry: If JPVT(I) <> 0, column I of A is permuted * to the front of AP (a leading column) * IF JPVT(I) == 0, column I of A is a free column. * on exit: If JPVT(I) = K, then the Ith column of AP * was the Kth column of A. * * TAU (output) COMPLEX array, dimension (min(M,N)) * Stores further details of * the orthogonal matrix Q (see A). * * WORK (workspace) COMPLEX array, dimension (N) * * RWORK (workspace) REAL array, dimension (2*N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * Further Details * =============== * * The matrix Q is represented as a product of elementary reflectors * * Q = H(1) H(2) . . . H(n) * * Each H(i) has the form * * H = I - tau * v * v' * * where tau is a complex scalar, and v is a complex vector with * v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i). * * The matrix P is represented in jpvt as follows: If * jpvt(j) = i * then the jth column of P is the ith canonical unit vector. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. INTEGER I, ITEMP, J, MA, MN, PVT REAL TEMP, TEMP2 COMPLEX AII * .. * .. External Subroutines .. EXTERNAL CGEQR2, CLARF, CLARFG, CSWAP, CUNM2R, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, CMPLX, CONJG, MAX, MIN, SQRT * .. * .. External Functions .. INTEGER ISAMAX REAL SCNRM2 EXTERNAL ISAMAX, SCNRM2 * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGEQPF', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * MN = MIN( M, N ) * * Move initial columns up front * ITEMP = 1 DO 10 I = 1, N IF( JPVT( I ).NE.0 ) THEN IF( I.NE.ITEMP ) THEN CALL CSWAP( M, A( 1, I ), 1, A( 1, ITEMP ), 1 ) JPVT( I ) = JPVT( ITEMP ) JPVT( ITEMP ) = I ELSE JPVT( I ) = I END IF ITEMP = ITEMP + 1 ELSE JPVT( I ) = I END IF 10 CONTINUE ITEMP = ITEMP - 1 * * Compute the QR factorization and update remaining columns * IF( ITEMP.GT.0 ) THEN MA = MIN( ITEMP, M ) CALL CGEQR2( M, MA, A, LDA, TAU, WORK, INFO ) IF( MA.LT.N ) THEN CALL CUNM2R( 'Left', 'Conjugate transpose', M, N-MA, MA, A, $ LDA, TAU, A( 1, MA+1 ), LDA, WORK, INFO ) END IF END IF * IF( ITEMP.LT.MN ) THEN * * Initialize partial column norms. The first n entries of * work store the exact column norms. * DO 20 I = ITEMP + 1, N RWORK( I ) = SCNRM2( M-ITEMP, A( ITEMP+1, I ), 1 ) RWORK( N+I ) = RWORK( I ) 20 CONTINUE * * Compute factorization * DO 40 I = ITEMP + 1, MN * * Determine ith pivot column and swap if necessary * PVT = ( I-1 ) + ISAMAX( N-I+1, RWORK( I ), 1 ) * IF( PVT.NE.I ) THEN CALL CSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 ) ITEMP = JPVT( PVT ) JPVT( PVT ) = JPVT( I ) JPVT( I ) = ITEMP RWORK( PVT ) = RWORK( I ) RWORK( N+PVT ) = RWORK( N+I ) END IF * * Generate elementary reflector H(i) * AII = A( I, I ) CALL CLARFG( M-I+1, AII, A( MIN( I+1, M ), I ), 1, $ TAU( I ) ) A( I, I ) = AII * IF( I.LT.N ) THEN * * Apply H(i) to A(i:m,i+1:n) from the left * AII = A( I, I ) A( I, I ) = CMPLX( ONE ) CALL CLARF( 'Left', M-I+1, N-I, A( I, I ), 1, $ CONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK ) A( I, I ) = AII END IF * * Update partial column norms * DO 30 J = I + 1, N IF( RWORK( J ).NE.ZERO ) THEN TEMP = ONE - ( ABS( A( I, J ) ) / RWORK( J ) )**2 TEMP = MAX( TEMP, ZERO ) TEMP2 = ONE + 0.05*TEMP*( RWORK( J ) / RWORK( N+J ) ) $ **2 IF( TEMP2.EQ.ONE ) THEN IF( M-I.GT.0 ) THEN RWORK( J ) = SCNRM2( M-I, A( I+1, J ), 1 ) RWORK( N+J ) = RWORK( J ) ELSE RWORK( J ) = ZERO RWORK( N+J ) = ZERO END IF ELSE RWORK( J ) = RWORK( J )*SQRT( TEMP ) END IF END IF 30 CONTINUE * 40 CONTINUE END IF RETURN * * End of CGEQPF * END ********************************************************************* SUBROUTINE CGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK routine (version 1.0b) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. COMPLEX A( LDA, * ), TAU( * ), WORK( LWORK ) * .. * * Purpose * ======= * * CGEQRF computes a QR factorization of a complex m by n matrix A: * A = Q * R. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * * A (input/output) COMPLEX array, dimension (LDA,N) * On entry, the m by n matrix A. * On exit, the elements on and above the diagonal of the array * contain the min(m,n) by n upper trapezoidal matrix R (R is * upper triangular if m >= n); the elements below the diagonal, * with the array TAU, represent the unitary matrix Q as a * product of elementary reflectors (see Further Details). * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * TAU (output) COMPLEX array, dimension (min(M,N)) * The scalar factors of the elementary reflectors (see Further * Details). * * WORK (workspace) COMPLEX array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the minimum value of * LWORK required to use the optimal blocksize. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= max(1,N). * For optimum performance LWORK should be at least N*NB, * where NB is the optimal blocksize. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * Further Details * =============== * * The matrix Q is represented as a product of elementary reflectors * * Q = H(1) H(2) . . . H(k), where k = min(m,n). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a complex scalar, and v is a complex vector with * v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), * and tau in TAU(i). * * ===================================================================== * * .. Local Scalars .. INTEGER I, IB, IINFO, IWS, K, LDWORK, NB, NBMIN, NX * .. * .. External Subroutines .. EXTERNAL CGEQR2, CLARFB, CLARFT, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 ELSE IF( LWORK.LT.MAX( 1, N ) ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGEQRF', -INFO ) RETURN END IF * * Quick return if possible * K = MIN( M, N ) IF( K.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * * Determine the block size. * NB = ILAENV( 1, 'CGEQRF', ' ', M, N, -1, -1 ) NBMIN = 2 NX = 0 IWS = N IF( NB.GT.1 .AND. NB.LT.K ) THEN * * Determine when to cross over from blocked to unblocked code. * NX = MAX( 0, ILAENV( 3, 'CGEQRF', ' ', M, N, -1, -1 ) ) IF( NX.LT.K ) THEN * * Determine if workspace is large enough for blocked code. * LDWORK = N IWS = LDWORK*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: reduce NB and * determine the minimum value of NB. * NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'CGEQRF', ' ', M, N, -1, $ -1 ) ) END IF END IF END IF * IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN * * Use blocked code initially * DO 10 I = 1, K - NX, NB IB = MIN( K-I+1, NB ) * * Compute the QR factorization of the current block * A(i:m,i:i+ib-1) * CALL CGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), WORK, $ IINFO ) IF( I+IB.LE.N ) THEN * * Form the triangular factor of the block reflector * H = H(i) H(i+1) . . . H(i+ib-1) * CALL CLARFT( 'Forward', 'Columnwise', M-I+1, IB, $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) * * Apply H' to A(i:m,i+ib:n) from the left * CALL CLARFB( 'Left', 'Conjugate transpose', 'Forward', $ 'Columnwise', M-I+1, N-I-IB+1, IB, $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), $ LDA, WORK( IB+1 ), LDWORK ) END IF 10 CONTINUE ELSE I = 1 END IF * * Use unblocked code to factor the last or only block. * IF( I.LE.K ) $ CALL CGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, $ IINFO ) * WORK( 1 ) = IWS RETURN * * End of CGEQRF * END ********************************************************************* SUBROUTINE CGEQR2( M, N, A, LDA, TAU, WORK, INFO ) * * -- LAPACK routine (version 1.0b) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * CGEQR2 computes a QR factorization of a complex m by n matrix A: * A = Q * R. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * * A (input/output) COMPLEX array, dimension (LDA,N) * On entry, the m by n matrix A. * On exit, the elements on and above the diagonal of the array * contain the min(m,n) by n upper trapezoidal matrix R (R is * upper triangular if m >= n); the elements below the diagonal, * with the array TAU, represent the unitary matrix Q as a * product of elementary reflectors (see Further Details). * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * TAU (output) COMPLEX array, dimension (min(M,N)) * The scalar factors of the elementary reflectors (see Further * Details). * * WORK (workspace) COMPLEX array, dimension (N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * Further Details * =============== * * The matrix Q is represented as a product of elementary reflectors * * Q = H(1) H(2) . . . H(k), where k = min(m,n). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a complex scalar, and v is a complex vector with * v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), * and tau in TAU(i). * * ===================================================================== * * .. Parameters .. COMPLEX ONE PARAMETER ( ONE = 1.0E+0 ) * .. * .. Local Scalars .. INTEGER I, K COMPLEX ALPHA * .. * .. External Subroutines .. EXTERNAL CLARF, CLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CONJG, MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGEQR2', -INFO ) RETURN END IF * K = MIN( M, N ) * DO 10 I = 1, K * * Generate elementary reflector H(i) to annihilate A(i+1:m,i) * CALL CLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, $ TAU( I ) ) IF( I.LT.N ) THEN * * Apply H(i)' to A(i:m,i+1:n) from the left * ALPHA = A( I, I ) A( I, I ) = ONE CALL CLARF( 'Left', M-I+1, N-I, A( I, I ), 1, $ CONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK ) A( I, I ) = ALPHA END IF 10 CONTINUE RETURN * * End of CGEQR2 * END ********************************************************************* SHAR_EOF fi # end of overwriting check if test -f 'ctrqpx.f' then echo shar: will not over-write existing file "'ctrqpx.f'" else cat << SHAR_EOF > 'ctrqpx.f' SUBROUTINE CTRQPX( JOB, M, N, K, A, LDA, C, LDC, JPVT, IRCOND, $ ORCOND, RANK, SVLUES, WORK, RWORK, INFO ) * * This code is part of a release of the package for computing * rank-revealing QR Factorizations written by: * ================================================================== * Christian H. Bischof and Gregorio Quintana-Orti * Math. and Comp. Sci. Div. Departamento de Informatica * Argonne National Lab. Universidad Jaime I * Argonne, IL 60439 Campus P. Roja, 12071 Castellon * USA Spain * bischof@mcs.anl.gov gquintan@inf.uji.es * ================================================================== * $Revision: 1.42 $ * $Date: 96/12/30 16:59:42 $ * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, RANK, INFO REAL IRCOND, ORCOND * .. * .. Array Arguments .. COMPLEX A( LDA, * ), C( LDC, * ), WORK( * ) REAL SVLUES( 4 ), RWORK( * ) INTEGER JPVT( * ) * .. * * Purpose * ======= * * CTRQPX detects the right rank for upper triangular matrix A. * The algorithm used here is related to Chandrasekaran&Ipsen * algorithm Hybrid-III. * This algorithm is applied to matrix A until the right rank is * obtained. If the input ordering of matrix A is not accepted, the * matrix will be permuted and retriangularized until the rank is * revealed. * * Arguments * ========= * * JOB (input) INTEGER * The job to do: * = 1: The transformations needed in the * triangularization are only applied to matrix A. * Thus, matrix C is not updated. * = 2: The same transformations needed in the * triangularization of matrix A are applied to * matrix C from the left. * That is, if Q'*A*P=R, then C := Q'*C. * In this case, matrix C is m-by-k. * = 3: The transpose of the transformations needed * in the triangularization of matrix A are applied * to matrix C from the right. * That is, if Q'*A*P=R, then C := C*Q. * In this case, matrix C is k-by-m. * In these three cases, the permutations are always stored * in vector JPVT. * * M (input) INTEGER * The number of rows of matrices A. M >= 0. * If JOB=2, M is the number of rows of matrix C. * If JOB=3, M is the number of columns of matrix C. * * N (input) INTEGER * The number of columns of matrix A. N >= 0. * * K (input) INTEGER * It defines the dimension of matrix C. K >= 0. * If JOB=2, K is the number of columns of matrix C. * If JOB=3, K is the number of rows of matrix C. * * A (input/output) COMPLEX array, dimension (LDA,N) * On entry, the m by n matrix A. * On exit, the upper triangle of the array contains the * min(m,n) by n upper trapezoidal matrix R; the lower triangle * array is filled with zeros. * * LDA (input) INTEGER * The leading dimension of array A. LDA >= max(1,M). * * C (input/output) COMPLEX array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the transformations * applied to matrix A are also applied to matrix C. * * LDC (input) INTEGER * The leading dimension of array C. * If JOB=2, then LDC >= MAX(1,M). * If JOB=3, then LDC >= MAX(1,K). * * JPVT (input/output) INTEGER array, dimension ( N ) * If JPVT(I) = K, then the Ith column of the permuted * A was the Kth column of the original A (just before * the preprocessing). If a permutation occurs, JPVT will * be updated correctly. * JPVT(1:RANK) contains the indices of the columns considered * linearly independent. * JPVT(RANK+1:N) contains the indices of the columns considered * linearly dependent from the previous ones. * * IRCOND (input) FLOATING_DECLARE * 1/IRCOND specifies an upper bound on the condition number * of R11. If IRCOND == 0, IRCOND = machine precision is chosen * as default. IRCOND must be >= 0. * * ORCOND (output) FLOATING_DECLARE * 1/ORCOND is an estimate for the condition number of R11. * * RANK (output) INTEGER * An estimate of the rank offered by this algorithm. * 0 <= RANK <= MIN(M,N). * * SVLUES (output) REAL array, dimension (4) * On exit, SVLUES contains estimates of some of the singular * values of the triangular factor R. * SVLUES(1): largest singular value of R(1:RANK,1:RANK) * SVLUES(2): smallest singular value of R(1:RANK,1:RANK) * SVLUES(3): smallest singular value of R(1:RANK+1,1:RANK+1) * SVLUES(4): smallest singular value of R * If the triangular factorization is a rank-revealing one * (which will be the case if the leading columns were well- * conditioned), then SVLUES(1) will also be an estimate * for the largest singular value of A, SVLUES(2) and SVLUES(3) * will be estimates for the RANK-th and (RANK+1)-st singular * value of A, and SVLUES(4) will be an estimate for the * smallest singular value of A. * By examining these values, one can confirm that the rank is * well defined with respect to the threshold chosen. * * WORK (workspace) COMPLEX array, dimension ( 2*MIN(M,N) ) * * RWORK (workspace) REAL array, dimension ( MIN(M,N)+N ) * * INFO (output) INTEGER * = 0: Successful exit. * < 0: If INFO = -i, the i-th argument had an illegal value * > 0: Problems in the computation of the rank. * 1: Exceeded the allowed maximum number of steps. * 2: Rank not well defined. * In adition, vector SVLUES tell if rank is not well defined. * When INFO.NE.0, the contents of ORCOND may be not the right * one. * * * =================================================================== * * .. Parameters .. INTEGER INB REAL ZERO PARAMETER ( INB = 1, ZERO = 0.0E+0 ) * * Indices into the 'svlues' array. * INTEGER IMAX, IBEFOR, IAFTER, IMIN PARAMETER ( IMAX = 1, IBEFOR = 2, IAFTER = 3, IMIN = 4 ) * .. * .. * .. Common Block .. INTEGER NB COMMON /BSPRQR/ NB * .. * .. Local Scalars .. REAL RCNR, RCNRP1, RCOND LOGICAL GOLEFT, RNKDTD INTEGER MN, OINFO * .. * .. External Functions .. INTEGER ILAENV REAL SLAMCH EXTERNAL ILAENV, SLAMCH * .. * .. External Subroutines .. EXTERNAL XERBLA, CTRQXC * .. * .. Intrinsic Functions .. INTRINSIC MIN, MAX * .. * .. Executable Statements .. * MN = MIN( M, N ) NB = ILAENV( INB, 'CGEQRF', ' ', M, N, 0, 0 ) * * Test input arguments * ==================== * INFO = 0 IF( ( JOB.LT.1 ).OR.( JOB.GT.3 ) ) THEN INFO = -1 ELSE IF( M.LT.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( K.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX(1,M) ) THEN INFO = -6 ELSE IF( ( ( JOB.EQ.1 ).AND.( LDC.LT.1 ) ).OR. $ ( ( JOB.EQ.2 ).AND.( LDC.LT.MAX( 1, M ) ) ).OR. $ ( ( JOB.EQ.3 ).AND.( LDC.LT.MAX( 1, K ) ) ) ) THEN INFO = -8 ELSE IF( IRCOND.LT.ZERO ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CTRQPX', -INFO ) RETURN END IF * * Quick return if possible. * IF( MN.EQ.0 ) THEN RANK = 0 ORCOND = ZERO SVLUES( IMAX ) = ZERO SVLUES( IBEFOR ) = ZERO SVLUES( IAFTER ) = ZERO SVLUES( IMIN ) = ZERO RETURN END IF * * Check whether Threshold for condition number was supplied. * If not, choose machine precision as default for RCOND. * IF( IRCOND.GT.ZERO ) THEN RCOND = IRCOND ELSE RCOND = SLAMCH( 'Epsilon' ) END IF * * Compute the initial estimate for the rank. * CALL CTRRNK( MN, A, LDA, RCOND, RANK, WORK, INFO ) * * ************************ * * First call to xTRQXC * * ************************ * * Get tighter bounds for the value RANK. * CALL CTRQXC( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ RANK, SVLUES, RCNR, RCNRP1, WORK, RWORK, INFO ) OINFO = 0 IF( INFO.NE.0 ) $ OINFO = INFO * * Check if the numerical rank is larger, equal or smaller than * the contents of RANK. * IF( ( ( RCNR.GE.RCOND ).AND.( RANK.EQ.MN ) ).OR. $ ( ( RCNR.GE.RCOND ).AND.( RCNRP1.LT.RCOND ) ) ) THEN RNKDTD = .TRUE. ELSE IF( ( RCNR.GE.RCOND ).AND.( RCNRP1.GE.RCOND ) ) THEN RNKDTD = .FALSE. GOLEFT = .FALSE. RANK = RANK + 1 ELSE IF( ( RCNR.LT.RCOND ).AND.( RCNRP1.LT.RCOND ) ) THEN IF( RANK.EQ.1 ) THEN RNKDTD = .TRUE. IF( ABS( A( 1, 1 ) ).EQ.ZERO ) THEN RANK = 0 ORCOND = ZERO SVLUES( IMAX ) = ZERO SVLUES( IBEFOR ) = ZERO SVLUES( IAFTER ) = ZERO SVLUES( IMIN ) = ZERO ELSE RANK = 1 END IF ELSE RNKDTD = .FALSE. GOLEFT = .TRUE. RANK = RANK - 1 END IF ELSE RNKDTD = .TRUE. INFO = 2 END IF * * ***************** * * Start of Loop * * ***************** * * Loop for the detection of the actual rank. The variable RANK is * updated until the rank is found. To avoid infinite loops, the * variable RANK either increases or decreases. * 10 CONTINUE IF( .NOT. RNKDTD ) THEN * * Call to xTRQXC to get tighter bounds for the value RANK. * CALL CTRQXC( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ RANK, SVLUES, RCNR, RCNRP1, WORK, RWORK, INFO ) IF( INFO.NE.0 ) $ OINFO = INFO * * Check if the numerical rank is larger, equal or smaller than * the contents of RANK. * IF( ( ( RCNR.GE.RCOND ).AND.( RANK.EQ.MN ) ).OR. $ ( ( RCNR.GE.RCOND ).AND.( RCNRP1.LT.RCOND ) ) ) THEN RNKDTD = .TRUE. ELSE IF( ( RCNR.GE.RCOND ).AND.( RCNRP1.GE.RCOND ) ) THEN IF( .NOT. GOLEFT ) THEN RANK = RANK + 1 ELSE RNKDTD = .TRUE. INFO = 2 END IF ELSE IF( ( RCNR.LT.RCOND ).AND.( RCNRP1.LT.RCOND ) ) THEN IF( RANK.EQ.1 ) THEN RNKDTD = .TRUE. IF( ABS( A( 1, 1 ) ).EQ.ZERO ) THEN RANK = 0 ORCOND = ZERO SVLUES( IMAX ) = ZERO SVLUES( IBEFOR ) = ZERO SVLUES( IAFTER ) = ZERO SVLUES( IMIN ) = ZERO ELSE RANK = 1 END IF ELSE GOLEFT = .TRUE. RANK = RANK - 1 END IF ELSE RNKDTD = .TRUE. INFO = 2 END IF * * Jump to the beginning of the loop. * GOTO 10 END IF * * *************** * * end of loop * * *************** * * Give back the obtained value of RCOND and check the value of INFO. * ORCOND = RCNR IF( OINFO.NE.0 ) $ INFO = OINFO * RETURN * * End of CTRQPX * END SHAR_EOF fi # end of overwriting check if test -f 'ctrqpy.f' then echo shar: will not over-write existing file "'ctrqpy.f'" else cat << SHAR_EOF > 'ctrqpy.f' SUBROUTINE CTRQPY( JOB, M, N, K, A, LDA, C, LDC, JPVT, IRCOND, $ ORCOND, RANK, SVLUES, WORK, RWORK, INFO ) * * This code is part of a release of the package for computing * rank-revealing QR Factorizations written by: * ================================================================== * Christian H. Bischof and Gregorio Quintana-Orti * Math. and Comp. Sci. Div. Departamento de Informatica * Argonne National Lab. Universidad Jaime I * Argonne, IL 60439 Campus P. Roja, 12071 Castellon * USA Spain * bischof@mcs.anl.gov gquintan@inf.uji.es * ================================================================== * $Revision: 1.42 $ * $Date: 96/12/30 16:59:43 $ * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, RANK, INFO REAL IRCOND, ORCOND * .. * .. Array Arguments .. COMPLEX A( LDA, * ), C( LDC, * ), WORK( * ) REAL SVLUES( 4 ), RWORK( * ) INTEGER JPVT( * ) * .. * * Purpose * ======= * * CTRQPY detects the right rank for upper triangular matrix A. * The algorithm used here is an version of Pan and Tang's RRQR * algorithm number 3. * This algorithm is applied to matrix A until the right rank is * obtained. If the input ordering of matrix A is not accepted, the * matrix will be permuted and retriangularized until the rank is * revealed. * * Arguments * ========= * * JOB (input) INTEGER * The job to do: * = 1: The transformations needed in the * triangularization are only applied to matrix A. * Thus, matrix C is not updated. * = 2: The same transformations needed in the * triangularization of matrix A are applied to * matrix C from the left. * That is, if Q'*A*P=R, then C := Q'*C. * In this case, matrix C is m-by-k. * = 3: The transpose of the transformations needed * in the triangularization of matrix A are applied * to matrix C from the right. * That is, if Q'*A*P=R, then C := C*Q. * In this case, matrix C is k-by-m. * In these three cases, the permutations are always stored * in vector JPVT. * * M (input) INTEGER * The number of rows of matrices A. M >= 0. * If JOB=2, M is the number of rows of matrix C. * If JOB=3, M is the number of columns of matrix C. * * N (input) INTEGER * The number of columns of matrix A. N >= 0. * * K (input) INTEGER * It defines the dimension of matrix C. K >= 0. * If JOB=2, K is the number of columns of matrix C. * If JOB=3, K is the number of rows of matrix C. * * A (input/output) COMPLEX array, dimension (LDA,N) * On entry, the m by n matrix A. * On exit, the upper triangle of the array contains the * min(m,n) by n upper trapezoidal matrix R; the lower triangle * array is filled with zeros. * * LDA (input) INTEGER * The leading dimension of array A. LDA >= max(1,M). * * C (input/output) COMPLEX array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the transformations * applied to matrix A are also applied to matrix C. * * LDC (input) INTEGER * The leading dimension of array C. * If JOB=2, then LDC >= MAX(1,M). * If JOB=3, then LDC >= MAX(1,K). * * JPVT (input/output) INTEGER array, dimension ( N ) * If JPVT(I) = K, then the Ith column of the permuted * A was the Kth column of the original A (just before * the preprocessing). If a permutation occurs, JPVT will * be updated correctly. * JPVT(1:RANK) contains the indices of the columns considered * linearly independent. * JPVT(RANK+1:N) contains the indices of the columns considered * linearly dependent from the previous ones. * * IRCOND (input) FLOATING_DECLARE * 1/IRCOND specifies an upper bound on the condition number * of R11. If IRCOND == 0, IRCOND = machine precision is chosen * as default. IRCOND must be >= 0. * * ORCOND (output) FLOATING_DECLARE * 1/ORCOND is an estimate for the condition number of R11. * * RANK (output) INTEGER * An estimate of the rank offered by this algorithm. * 0 <= RANK <= MIN(M,N). * * SVLUES (output) REAL array, dimension (4) * On exit, SVLUES contains estimates of some of the singular * values of the triangular factor R. * SVLUES(1): largest singular value of R(1:RANK,1:RANK) * SVLUES(2): smallest singular value of R(1:RANK,1:RANK) * SVLUES(3): smallest singular value of R(1:RANK+1,1:RANK+1) * SVLUES(4): smallest singular value of R * If the triangular factorization is a rank-revealing one * (which will be the case if the leading columns were well- * conditioned), then SVLUES(1) will also be an estimate * for the largest singular value of A, SVLUES(2) and SVLUES(3) * will be estimates for the RANK-th and (RANK+1)-st singular * value of A, and SVLUES(4) will be an estimate for the * smallest singular value of A. * By examining these values, one can confirm that the rank is * well defined with respect to the threshold chosen. * * WORK (workspace) COMPLEX array, dimension ( MIN(M,N) ) * * RWORK (workspace) REAL array, dimension ( MIN(M,N)+N ) * * INFO (output) INTEGER * = 0: Successful exit. * < 0: If INFO = -i, the i-th argument had an illegal value * > 0: Problems in the computation of the rank. * 1: Exceeded the allowed maximum number of steps. * 2: Rank not well defined. * In adition, vector SVLUES tell if rank is not well defined. * When INFO.NE.0, the contents of ORCOND may be not the right * one. * * * =================================================================== * * .. Parameters .. INTEGER INB REAL ZERO PARAMETER ( INB = 1, ZERO = 0.0E+0 ) * * Indices into the 'svlues' array. * INTEGER IMAX, IBEFOR, IAFTER, IMIN PARAMETER ( IMAX = 1, IBEFOR = 2, IAFTER = 3, IMIN = 4 ) * .. * .. * .. Common Block .. INTEGER NB COMMON /BSPRQR/ NB * .. * .. Local Scalars .. REAL RCNR, RCNRP1, RCOND LOGICAL GOLEFT, RNKDTD INTEGER MN, OINFO * .. * .. External Functions .. INTEGER ILAENV REAL SLAMCH EXTERNAL ILAENV, SLAMCH * .. * .. External Subroutines .. EXTERNAL XERBLA, CTRQYC, CTRRNK * .. * .. Intrinsic Functions .. INTRINSIC MIN, MAX * .. * .. Executable Statements .. * MN = MIN( M, N ) NB = ILAENV( INB, 'CGEQRF', ' ', M, N, 0, 0 ) * * Test input arguments * ==================== * INFO = 0 IF( ( JOB.LT.1 ).OR.( JOB.GT.3 ) ) THEN INFO = -1 ELSE IF( M.LT.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( K.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX(1,M) ) THEN INFO = -6 ELSE IF( ( ( JOB.EQ.1 ).AND.( LDC.LT.1 ) ).OR. $ ( ( JOB.EQ.2 ).AND.( LDC.LT.MAX( 1, M ) ) ).OR. $ ( ( JOB.EQ.3 ).AND.( LDC.LT.MAX( 1, K ) ) ) ) THEN INFO = -8 ELSE IF( IRCOND.LT.ZERO ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CTRQPY', -INFO ) RETURN END IF * * Quick return if possible. * IF( MN.EQ.0 ) THEN RANK = 0 ORCOND = ZERO SVLUES( IMAX ) = ZERO SVLUES( IBEFOR ) = ZERO SVLUES( IAFTER ) = ZERO SVLUES( IMIN ) = ZERO RETURN END IF * * Check whether Threshold for condition number was supplied. * If not, choose machine precision as default for RCOND. * IF( IRCOND.GT.ZERO ) THEN RCOND = IRCOND ELSE RCOND = SLAMCH( 'Epsilon' ) END IF * * Compute the initial estimate for the rank. * CALL CTRRNK( MN, A, LDA, RCOND, RANK, WORK, INFO ) * * ************************ * * First call to xTRQYC * * ************************ * * Get tighter bounds for the value RANK. * CALL CTRQYC( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ RANK, SVLUES, RCNR, RCNRP1, WORK, RWORK, INFO ) OINFO = 0 IF( INFO.NE.0 ) $ OINFO = INFO * * Check if the numerical rank is larger, equal or smaller than * the contents of RANK. * IF( ( ( RCNR.GE.RCOND ).AND.( RANK.EQ.MN ) ).OR. $ ( ( RCNR.GE.RCOND ).AND.( RCNRP1.LT.RCOND ) ) ) THEN RNKDTD = .TRUE. ELSE IF( ( RCNR.GE.RCOND ).AND.( RCNRP1.GE.RCOND ) ) THEN RNKDTD = .FALSE. GOLEFT = .FALSE. RANK = RANK + 1 ELSE IF( ( RCNR.LT.RCOND ).AND.( RCNRP1.LT.RCOND ) ) THEN IF( RANK.EQ.1 ) THEN RNKDTD = .TRUE. IF( ABS( A( 1, 1 ) ).EQ.ZERO ) THEN RANK = 0 ORCOND = ZERO SVLUES( IMAX ) = ZERO SVLUES( IBEFOR ) = ZERO SVLUES( IAFTER ) = ZERO SVLUES( IMIN ) = ZERO ELSE RANK = 1 END IF ELSE RNKDTD = .FALSE. GOLEFT = .TRUE. RANK = RANK - 1 END IF ELSE RNKDTD = .TRUE. INFO = 2 END IF * * ***************** * * Start of Loop * * ***************** * * Loop for the detection of the actual rank. The variable RANK is * updated until the rank is found. To avoid infinite loops, the * variable RANK either increases or decreases. * 10 CONTINUE IF( .NOT. RNKDTD ) THEN * * Call to xTRQYC to get tighter bounds for the value RANK. * CALL CTRQYC( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ RANK, SVLUES, RCNR, RCNRP1, WORK, RWORK, INFO ) IF( INFO.NE.0 ) $ OINFO = INFO * * Check if the numerical rank is larger, equal or smaller than * the contents of RANK. * IF( ( ( RCNR.GE.RCOND ).AND.( RANK.EQ.MN ) ).OR. $ ( ( RCNR.GE.RCOND ).AND.( RCNRP1.LT.RCOND ) ) ) THEN RNKDTD = .TRUE. ELSE IF( ( RCNR.GE.RCOND ).AND.( RCNRP1.GE.RCOND ) ) THEN IF( .NOT. GOLEFT ) THEN RANK = RANK + 1 ELSE RNKDTD = .TRUE. INFO = 2 END IF ELSE IF( ( RCNR.LT.RCOND ).AND.( RCNRP1.LT.RCOND ) ) THEN IF( RANK.EQ.1 ) THEN RNKDTD = .TRUE. IF( ABS( A( 1, 1 ) ).EQ.ZERO ) THEN RANK = 0 ORCOND = ZERO SVLUES( IMAX ) = ZERO SVLUES( IBEFOR ) = ZERO SVLUES( IAFTER ) = ZERO SVLUES( IMIN ) = ZERO ELSE RANK = 1 END IF ELSE GOLEFT = .TRUE. RANK = RANK - 1 END IF ELSE RNKDTD = .TRUE. INFO = 2 END IF * * Jump to the beginning of the loop. * GOTO 10 END IF * * *************** * * end of loop * * *************** * * Give back the obtained value of RCOND and check the value of INFO. * ORCOND = RCNR IF( OINFO.NE.0 ) $ INFO = OINFO * RETURN * * End of CTRQPY * END SHAR_EOF fi # end of overwriting check if test -f 'ctrqxc.f' then echo shar: will not over-write existing file "'ctrqxc.f'" else cat << SHAR_EOF > 'ctrqxc.f' SUBROUTINE CTRQXC( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ RANK, SVLUES, RCNR, RCNRP1, WORK, RWORK, INFO ) * * This code is part of a release of the package for computing * rank-revealing QR Factorizations written by: * ================================================================== * Christian H. Bischof and Gregorio Quintana-Orti * Math. and Comp. Sci. Div. Departamento de Informatica * Argonne National Lab. Universidad Jaime I * Argonne, IL 60439 Campus P. Roja, 12071 Castellon * USA Spain * bischof@mcs.anl.gov gquintan@inf.uji.es * ================================================================== * $Revision: 1.42 $ * $Date: 96/12/30 16:59:43 $ * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, RANK, INFO REAL RCNR, RCNRP1 * .. * .. Array Arguments .. COMPLEX A( LDA, * ), C( LDC, * ), WORK( * ) REAL SVLUES( 4 ), RWORK( * ) INTEGER JPVT( * ) * .. * * Purpose * ======= * * CTRQXC carries out an algorithm related to algorithm Hybrid-III * by Chandrasekaran and Ipsen for the stage RANK. The algorithm used * here offers the following advantages: * o It is faster since it is based on Chan-II instead of Stewart-II. * o This algorithm uses the F factor technique to reduce the number of * cycling problems due to roundoff errors. * o The final steps that do not improve the ordering are saved. * * Arguments * ========= * * JOB (input) INTEGER * The job to do: * = 1: The transformations needed in the * triangularization are only applied to matrix A. * Thus, matrix C is not updated. * = 2: The same transformations needed in the * triangularization of matrix A are applied to * matrix C from the left. * That is, if Q'*A*P=R, then C := Q'*C. * In this case, matrix C is m-by-k. * = 3: The transpose of the transformations needed * in the triangularization of matrix A are applied * to matrix C from the right. * That is, if Q'*A*P=R, then C := C*Q. * In this case, matrix C is k-by-m. * In these three cases, the permutations are always stored * in vector JPVT. * * M (input) INTEGER * The number of rows of matrices A. M >= 0. * If JOB=2, M is the number of rows of matrix C. * If JOB=3, M is the number of columns of matrix C. * * N (input) INTEGER * The number of columns of matrix A. N >= 0. * * K (input) INTEGER * It defines the dimension of matrix C. K >= 0. * If JOB=2, K is the number of columns of matrix C. * If JOB=3, K is the number of rows of matrix C. * * A (input/output) COMPLEX array, dimension (LDA,N) * On entry, the m by n matrix A. * On exit, the upper triangle of the array contains the * min(m,n) by n upper trapezoidal matrix R; the lower triangle * array is filled with zeros. * * LDA (input) INTEGER * The leading dimension of array A. LDA >= max(1,M). * * C (input/output) COMPLEX array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the transformations * applied to matrix A are also applied to matrix C. * * LDC (input) INTEGER * The leading dimension of array C. * If JOB=2, then LDC >= MAX(1,M). * If JOB=3, then LDC >= MAX(1,K). * * JPVT (input/output) INTEGER array, dimension ( N ) * If JPVT(I) = K, then the Ith column of the permuted * A was the Kth column of the original A (just before * the preprocessing). If a permutation occurs, JPVT will * be updated correctly. * * RANK (input) INTEGER * The estimate of the rank. 1 <= RANK <= MIN(M,N). * * SVLUES (output) REAL array, dimension (4) * On exit, SVLUES contains estimates of some of the singular * values of the triangular factor R. * SVLUES(1): largest singular value of R(1:RANK,1:RANK) * SVLUES(2): smallest singular value of R(1:RANK,1:RANK) * SVLUES(3): smallest singular value of R(1:RANK+1,1:RANK+1) * SVLUES(4): smallest singular value of R * If the triangular factorization is a rank-revealing one * (which will be the case if the leading columns were well- * conditioned), then SVLUES(1) will also be an estimate * for the largest singular value of A, SVLUES(2) and SVLUES(3) * will be estimates for the RANK-th and (RANK+1)-st singular * value of A, and SVLUES(4) wil be an estimate for the * smallest singular value of A. * By examining these values, one can confirm that the rank is * well defined with respect to the threshold chosen. * * RCNR (output) REAL * The estimate for the inverse of the condition number of * block R(1:RANK,1:RANK). * * RCNRP1 (output) REAL * The estimate for the inverse of the condition number of * block R(1:RANK+1,1:RANK+1). * * WORK (workspace) COMPLEX array, dimension ( 2*MIN(M,N) ). * * RWORK (workspace) REAL array, dimension ( MIN(M,N)+N ). * * INFO (output) INTEGER * = 0: Successful exit. * < 0: If info = -i, the i-th argument had an illegal value. * = 4: Exceeded the allowed maximum number of steps. That is, * the matrix presents a slow convergence. * * * =================================================================== * * .. Parameters .. REAL F COMPLEX CONE PARAMETER ( F = 0.5E+0, CONE = ( 1.0E+0, 0.0E+0 ) ) * * Indices into the 'svlues' array. * INTEGER IMAX, IBEFOR, IAFTER, IMIN PARAMETER ( IMAX = 1, IBEFOR = 2, IAFTER = 3, IMIN = 4 ) * .. * .. Local Scalars .. REAL SMAX, SMAXPR, SMIN, SMINPR, SMXRP1 COMPLEX COSINE, SINE LOGICAL PERMUT INTEGER J, MN, MXSTPS, NACPTD INTEGER NS * .. * .. External Subroutines .. EXTERNAL CSCAL * .. * .. External Functions .. INTEGER ISAMAX REAL SLASMX, SCNRM2 EXTERNAL ISAMAX, SLASMX, SCNRM2 * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * MN = MIN( M, N ) NS = 0 MXSTPS = N + 25 INFO = 0 * * Quick return if possible. * IF( MN.EQ.0 ) $ RETURN * * Inicialization of variable NACPTD, which controls main loop. * NACPTD = 0 * * Compute the norms of block A(1:RANK,1:RANK) and store them * in vector RWORK(1:RANK). It is computed only once at the * beginning and updated every iteration. It is used to estimate * the largest singular value in order to pass it to Chan-II. * DO 10 J = 1, RANK RWORK( J ) = SCNRM2( J, A( 1, J ), 1 ) 10 CONTINUE * * ***************** * * start of loop * * ***************** * 20 CONTINUE * * *-*-*-*-*-*-*-*-*-*-*-*-* * * call to Golub-I(rank) * * *-*-*-*-*-*-*-*-*-*-*-*-* * IF( NACPTD.LT.4 ) THEN * * Apply Golub-I for the stage RANK. * CALL CGLBIF( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ F, RANK, PERMUT, WORK, RWORK( MN+1 ), INFO ) * * If necessary, update the contents of WORK(RANK). * IF( PERMUT ) $ RWORK( RANK ) = SCNRM2( RANK, A( 1, RANK ), 1 ) * * Update variables NACPTD and NS. * IF( PERMUT ) THEN NACPTD = 1 ELSE NACPTD = NACPTD+1 END IF NS = NS + 1 END IF * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * call to Golub-I(rank+1) * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * IF( NACPTD.LT.4 ) THEN * * Determine if the application of Golub-I(rank+1) is necessary. * IF( RANK.EQ.MN ) THEN * * Not necessary. Therefore, no permutation occurs. * PERMUT = .FALSE. ELSE * * Apply Golub-I for the stage RANK+1. * CALL CGLBIF( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ F, RANK+1, PERMUT, WORK, RWORK( MN+1 ), INFO ) * * Update variable NS. * NS = NS+1 END IF * * Update variable NACPTD. * IF( PERMUT ) THEN NACPTD = 1 ELSE NACPTD = NACPTD+1 END IF END IF * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * call to Chan-II (rank+1)* * *-*-*-*-*-*-*-*-*-*-*-*-*-* * IF( NACPTD.LT.4 ) THEN * * Determine if the application of Chan-II(rank+1) is necessary. * IF( RANK.EQ.MN ) THEN * * Not necessary. Therefore, no permutation occurs. * PERMUT = .FALSE. ELSE * * Extend vector WORK(1:RANK) to vector WORK(1:RANK+1). * So, pivoting vector WORK(1:N) inside Chan-II will be * easier. * RWORK( RANK+1 ) = SCNRM2( RANK+1, A( 1, RANK+1 ), 1 ) * * Apply Chan-II for the stage RANK+1 * on block A(1:RANK+1,1:RANK+1). * CALL CCNIIF( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ RWORK, F, RANK+1, PERMUT, WORK, $ RWORK( MN+1 ), INFO ) * * Update variable NS. * NS = NS+1 END IF * * Update variable NACPTD. * IF( PERMUT ) THEN NACPTD = 1 ELSE NACPTD = NACPTD+1 END IF END IF * * *-*-*-*-*-*-*-*-*-*-*-*-* * * call to Chan-II(rank) * * *-*-*-*-*-*-*-*-*-*-*-*-* * IF( NACPTD.LT.4 ) THEN * * Apply Chan-II for the stage RANK on block A(1:RANK,1:RANK). * CALL CCNIIF( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ RWORK, F, RANK, PERMUT, WORK, $ RWORK( MN+1 ), INFO ) * * Update variables NACPTD and NS. * IF( PERMUT ) THEN NACPTD = 1 ELSE NACPTD = NACPTD+1 END IF NS = NS + 1 END IF * * Check if loop must finish. * IF( NS.GE.MXSTPS ) THEN INFO = 1 ELSE IF( NACPTD.LT.4 ) THEN GOTO 20 END IF * * *************** * * end of loop * * *************** * * Computation of the largest singular value of A(1:RANK,1:RANK). * SMAX = ABS( A( 1, 1 ) ) WORK( 1 ) = CONE SMIN = SMAX WORK( MN+1 ) = CONE * DO 30 J = 2, RANK CALL CLAIC1( 1, J-1, WORK( 1 ), SMAX, $ A( 1, J ), A( J, J ), SMAXPR, SINE, COSINE ) CALL CSCAL( J-1, SINE, WORK( 1 ), 1 ) WORK( J ) = COSINE SMAX = SMAXPR CALL CLAIC1( 2, J-1, WORK( MN+1 ), SMIN, $ A( 1, J ), A( J, J ), SMINPR, SINE, COSINE ) CALL CSCAL( J-1, SINE, WORK( MN+1 ), 1 ) WORK( MN+J ) = COSINE SMIN = SMINPR 30 CONTINUE SVLUES( IMAX ) = SMAX SVLUES( IBEFOR ) = SMIN * * Computation of the largest singular value and the smallest * singular value of A(1:RANK+1,1:RANK+1). * IF( RANK.LT.MN ) THEN CALL CLAIC1( 1, RANK, WORK( 1 ), SMAX, $ A( 1, RANK+1 ), A( RANK+1, RANK+1 ), SMAXPR, $ SINE, COSINE ) SMAX = SMAXPR CALL CLAIC1( 2, RANK, WORK( MN+1 ), SMIN, $ A( 1, RANK+1 ), A( RANK+1, RANK+1 ), SMINPR, $ SINE, COSINE ) CALL CSCAL( RANK, SINE, WORK( MN+1 ), 1 ) WORK( MN+RANK+1 ) = COSINE SMIN = SMINPR END IF SMXRP1 = SMAX SVLUES( IAFTER ) = SMIN * * Computation of the smallest singular value of A(1:MN,1:MN). * DO 40 J = RANK+2, MN CALL CLAIC1( 2, J-1, WORK( MN+1 ), SMIN, $ A( 1, J ), A( J, J ), SMINPR, SINE, COSINE ) CALL CSCAL( J-1, SINE, WORK( MN+1 ), 1 ) WORK( MN+J ) = COSINE SMIN = SMINPR 40 CONTINUE SVLUES( IMIN ) = SMIN * * Computation of RCNR and RCNRP1. * RCNR = SVLUES( IBEFOR ) / SVLUES( IMAX ) RCNRP1 = SVLUES( IAFTER ) / SMXRP1 RETURN * * End of CTRQXC * END SUBROUTINE CGLBIF( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ F, RANK, PERMUT, WORK, RWORK, INFO ) * * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, RANK, INFO REAL F LOGICAL PERMUT * .. * .. Array Arguments .. COMPLEX A( LDA, * ), C( LDC, * ), WORK( * ) REAL RWORK( * ) INTEGER JPVT( * ) * .. * * Purpose * ======= * * CGLBIF computes the column index of A(RANK:M,RANK:N) with largest * norm and determines if pivoting is necessary. If so, it pivots it * into column RANK, permuts vector JPVT, adjusts vector VNORM and * permuts and retriangularizes matrix A. It does only one permutation. * * Arguments * ========= * * JOB (input) INTEGER * The job to do: * = 1: The transformations needed in the * triangularization are only applied to matrix A. * Thus, matrix C is not updated. * = 2: The same transformations needed in the * triangularization of matrix A are applied to * matrix C from the left. * That is, if Q'*A*P=R, then C := Q'*C. * In this case, matrix C is m-by-k. * = 3: The transpose of the transformations needed * in the triangularization of matrix A are applied * to matrix C from the right. * That is, if Q'*A*P=R, then C := C*Q. * In this case, matrix C is k-by-m. * In these three cases, the permutations are always stored * in vector JPVT. * * M (input) INTEGER * The number of rows of matrices A. M >= 0. * If JOB=2, M is the number of rows of matrix C. * If JOB=3, M is the number of columns of matrix C. * * N (input) INTEGER * The number of columns of matrix A. N >= 0. * * K (input) INTEGER * It defines the dimension of matrix C. K >= 0. * If JOB=2, K is the number of columns of matrix C. * If JOB=3, K is the number of rows of matrix C. * * A (input/output) COMPLEX array, dimension (LDA,N) * On entry, the m by n matrix A. * On exit, the upper triangle of the array contains the * min(m,n) by n upper trapezoidal matrix R; the lower triangle * array is filled with zeros. * * LDA (input) INTEGER * The leading dimension of array A. LDA >= max(1,M). * * C (input/output) COMPLEX array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the transformations * applied to matrix A are also applied to matrix C. * * LDC (input) INTEGER * The leading dimension of array C. * If JOB=2, then LDC >= MAX(1,M). * If JOB=3, then LDC >= MAX(1,K). * * JPVT (input/output) INTEGER array, dimension ( N ) * If JPVT(I) = K, then the Ith column of the permuted * A was the Kth column of the original A (just before the * preprocessing). If a permutation occurs, it will be * updated correctly. * * F (input) REAL * F factor for the pivoting. It must be always 0 < f <= 1. * * RANK (input) INTEGER * The estimate for the rank. 1 <= RANK <= MIN(M,N). * * PERMUT (output) LOGICAL * Tells if a permutation occurred. * * WORK (workspace) COMPLEX array, dimension ( MIN(M,N) ) * * RWORK (workspace) REAL array, dimension ( N ) * * INFO (output) INTEGER * = 0: Successful exit. * < 0: If info = -i, the i-th argument had an illegal value. * * ===================================================================== * * .. Parameters .. * .. * .. Local Scalars .. INTEGER MN, JJ, J, ITEMP * .. * .. Local Scalars .. COMPLEX CDUMMY( 1, 1 ) * .. * .. External Subroutines .. EXTERNAL CCOPY, CGRET * .. * .. External Functions .. INTEGER ISAMAX REAL SCNRM2 EXTERNAL ISAMAX, SCNRM2 * .. * .. Executable Statements .. * MN = MIN( M, N ) INFO = 0 * * Quick return if possible. * IF( ( MN.EQ.0 ).OR.( RANK.EQ.N ) ) THEN PERMUT = .FALSE. RETURN END IF * * Compute the norms of the columns of block A(RANK:M,RANK:N) * and store them in vector RWORK(RANK:N). * DO 10 J = RANK, N RWORK( J ) = $ SCNRM2( MIN( M, J )-RANK+1, A( RANK, J ), 1 ) 10 CONTINUE * * Find column with largest two-norm of upper triangular block * A(RANK:M,RANK:N). Use the data stored in vector RWORK(RANK:N). * JJ = RANK - 1 + ISAMAX( N-RANK+1, RWORK( RANK ), 1) * * Determine if a permutation must occur. * PERMUT = ( ( JJ.GT.RANK ).AND. $ ( ( ABS( RWORK( JJ ) )*F ).GT.ABS( RWORK( RANK ) ) ) ) * IF( PERMUT ) THEN * * Exchage cyclically to the right the columns of matrix A * between RANK and JJ. That is, RANK->RANK+1, * RANK+1->RANK+2,...,JJ-1->JJ,JJ->K. Use vector WORK(1:MN) * to store temporal data. * CALL CCOPY( MIN( MN, JJ ), A( 1, JJ ), 1, WORK, 1 ) DO 20 J = JJ-1, RANK, -1 CALL CCOPY( MIN( MN, J+1 ), A( 1, J ), 1, $ A( 1, J+1 ), 1 ) 20 CONTINUE CALL CCOPY( MIN( MN, JJ ), WORK, 1, A( 1, RANK ), 1 ) * * Exchange in the same way vector JPVT. * ITEMP = JPVT( JJ ) DO 30 J = JJ-1, RANK, -1 JPVT( J+1 ) = JPVT( J ) 30 CONTINUE JPVT( RANK ) = ITEMP * * Retriangularize matrix A after the permutation. * IF( JOB.EQ.1 ) THEN CALL CGRET( JOB, MIN( M, JJ )-RANK+1, N-RANK+1, K, $ A( RANK, RANK ), LDA, CDUMMY, 1, $ WORK, RWORK, INFO ) ELSE IF( JOB.EQ.2 ) THEN CALL CGRET( JOB, MIN( M, JJ )-RANK+1, N-RANK+1, K, $ A( RANK, RANK ), LDA, C( RANK, 1 ), LDC, $ WORK, RWORK, INFO ) ELSE IF( JOB.EQ.3 ) THEN CALL CGRET( JOB, MIN( M, JJ )-RANK+1, N-RANK+1, K, $ A( RANK, RANK ), LDA, C( 1, RANK ), LDC, $ WORK, RWORK, INFO ) END IF END IF RETURN * * End of CGLBIF * END SUBROUTINE CCNIIF( JOB, M, N, K, A, LDA, C, LDC, JPVT, VNORM, $ F, RANK, PERMUT, WORK, RWORK, INFO ) * * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, RANK, INFO REAL F LOGICAL PERMUT * .. * .. Array Arguments .. COMPLEX A( LDA, * ), C( LDC, * ), WORK( * ) REAL VNORM( * ), RWORK( * ) INTEGER JPVT( * ) * .. * * Purpose * ======= * * CCNIIF computes the "worst" column in A(1:RANK,1:RANK) and * determines if pivoting is necessary. If so, it pivots it into column * RANK, permuts vector JPVT, adjusts vector VNORM and permuts and * retriangularizes matrix A. It does only one permutation. * * Arguments * ========= * * JOB (input) INTEGER * The job to do: * = 1: The transformations needed in the * triangularization are only applied to matrix A. * Thus, matrix C is not updated. * = 2: The same transformations needed in the * triangularization of matrix A are applied to * matrix C from the left. * That is, if Q'*A*P=R, then C := Q'*C. * In this case, matrix C is m-by-k. * = 3: The transpose of the transformations needed * in the triangularization of matrix A are applied * to matrix C from the right. * That is, if Q'*A*P=R, then C := C*Q. * In this case, matrix C is k-by-m. * In these three cases, the permutations are always stored * in vector JPVT. * * M (input) INTEGER * The number of rows of matrices A. M >= 0. * If JOB=2, M is the number of rows of matrix C. * If JOB=3, M is the number of columns of matrix C. * * N (input) INTEGER * The number of columns of matrix A. N >= 0. * * K (input) INTEGER * It defines the dimension of matrix C. K >= 0. * If JOB=2, K is the number of columns of matrix C. * If JOB=3, K is the number of rows of matrix C. * * A (input/output) COMPLEX array, dimension (LDA,N) * On entry, the m by n matrix A. * On exit, the upper triangle of the array contains the * min(m,n) by n upper trapezoidal matrix R; the lower triangle * array is filled with zeros. * * LDA (input) INTEGER * The leading dimension of array A. LDA >= MAX(1,M). * * C (input/output) COMPLEX array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the transformations * applied to matrix A are also applied to matrix C. * * LDC (input) INTEGER * The leading dimension of array C. * If JOB=2, then LDC >= MAX(1,M). * If JOB=3, then LDC >= MAX(1,K). * * JPVT (input/output) INTEGER array, dimension (N) * If JPVT(I) = K, then the Ith column of the permuted * A was the Kth column of the original A (just before the * preprocessing). If a permutation occurs, this vector will * be updated correctly. * * VNORM (input/output) REAL array, dimension ( N ) * VNORM(1:RANK) contains the norms of the columns of upper * triangular block A(1:RANK,1:RANK). If a permutation occurs, * this vector will be updated correctly. * * F (input) REAL * F factor for the pivoting. It must be always 0 < f <= 1. * * RANK (input) INTEGER * The estimate for the rank. 1 <= RANK <= MIN(M,N). * * PERMUT (output) LOGICAL * Tells if a permutation occurred. * * WORK (workspace) COMPLEX array, dimension ( MIN(M,N) ) * * RWORK (workspace) REAL array, dimension ( MIN(M,N) ) * * INFO (output) INTEGER * = 0: Successful exit. * < 0: If info = -i, the i-th argument had an illegal value. * * Further Details * =============== * * If block R(1:RANK,1:RANK) is singular or near singular, there will * be no permutation because in that case the right (and left) singular * vectors are the canonical ones ((0,0,...0,1)^T). * That is, there will not be permutation if * RCOND <= SF * SLAMCH('Safe Minimum'), where SF (Safe Factor) is * a security factor to avoid arithmetic exceptions. * * ===================================================================== * * .. Parameters .. REAL SF PARAMETER ( SF = 1.0E+2 ) COMPLEX CONE PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. INTEGER MN, JJ, J, ITEMP REAL SMAX, SMIN, SMINPR, TEMP COMPLEX SINE, COSINE * .. * .. Local Arrays .. COMPLEX CDUMMY( 1, 1 ) * .. * .. External Subroutines .. EXTERNAL CCOPY, CTRSV, CHESS * .. * .. External Functions .. INTEGER ISAMAX, ICAMAX REAL SCNRM2, SLAMCH, SLASMX EXTERNAL ISAMAX, ICAMAX, SCNRM2, $ SLAMCH, SLASMX * .. * .. Executable Statements .. * MN = MIN( M, N ) INFO = 0 * * Quick return if possible. * IF( ( MN.EQ.0 ).OR.( RANK.EQ.1 ) ) THEN PERMUT = .FALSE. RETURN END IF * * Estimation of the largest singular value of block * A(1:RANK,1:RANK) by using the contents of vector * VNORM. * ITEMP = ISAMAX( RANK, VNORM, 1 ) SMAX = SLASMX( RANK ) * VNORM( ITEMP ) * * Estimation of the smallest singular value of block * A(1:RANK,1:RANK) and its corresponding left singular vector. * Save left singular vector in vector WORK(1:RANK). * SMIN = ABS( A( 1, 1 ) ) WORK( 1 ) = CONE DO 10 J = 2, RANK CALL CLAIC1( 2, J-1, WORK( 1 ), SMIN, A( 1, J ), $ A( J , J ), SMINPR, SINE, COSINE ) CALL CSCAL( J-1, SINE, WORK( 1 ), 1 ) WORK( J ) = COSINE SMIN = SMINPR 10 CONTINUE * * Determine if matrix A(1:RANK,1:RANK) is singular or nearly * singular. SF (Safe Factor) is used to say if it is singular or not. * IF( SMIN.LE.( SMAX*SF*SLAMCH( 'Safe minimum' ) ) ) THEN * * Singular or nearly singular matrix. Its right singular * vector is (0,0,...,0,1)^T. So, no pivoting is needed. * PERMUT = .FALSE. ELSE * * Follow usual method: Estimate the right singular vector * corresponding to the smallest singular value of upper * triangular block A(1:RANK,1:RANK) and store in vector * WORK(1:RANK). * CALL CTRSV( 'Upper', 'No transpose', 'No unit', $ RANK, A, LDA, WORK, 1) * * Find the index with largest absolute value in vector * WORK(1:RANK). * JJ = ICAMAX( RANK, WORK, 1 ) * * Determine if a permutation must occur. * PERMUT = ( ( JJ.LT.RANK ).AND. $ ( ( ABS( WORK( JJ ) )*F ).GT.ABS( WORK( RANK ) ) ) ) * IF( PERMUT ) THEN * * Exchange cyclically to the left the colums of matrix A * between JJ and RANK. That is, JJ->RANK,JJ+1->JJ,..., * RANK->RANK-1. Use vector WORK to store temporal data. * CALL CCOPY( RANK, A( 1, JJ ), 1, WORK, 1 ) DO 20 J = JJ+1, RANK CALL CCOPY( J, A( 1, J ), 1, A( 1, J-1 ), 1 ) 20 CONTINUE CALL CCOPY( RANK, WORK, 1, A( 1, RANK ), 1 ) * * Exchange in the same way vector JPVT. * ITEMP = JPVT( JJ ) DO 30 J = JJ+1, RANK JPVT( J-1 ) = JPVT( J ) 30 CONTINUE JPVT( RANK ) = ITEMP * * Adjust the contents of VNORM. * TEMP = VNORM( JJ ) DO 40 J = JJ+1, RANK VNORM( J-1 ) = VNORM( J ) 40 CONTINUE VNORM( RANK ) = TEMP * * Retriangularize matrix A after the permutation. * IF( JOB.EQ.1 ) THEN CALL CHESS( JOB, RANK-JJ+1, N-JJ+1, K, $ A( JJ, JJ ), LDA, CDUMMY, 1, $ WORK, RWORK, INFO ) ELSE IF( JOB.EQ.2 ) THEN CALL CHESS( JOB, RANK-JJ+1, N-JJ+1, K, $ A( JJ, JJ ), LDA, C( JJ, 1 ), LDC, $ WORK, RWORK, INFO ) ELSE IF( JOB.EQ.3 ) THEN CALL CHESS( JOB, RANK-JJ+1, N-JJ+1, K, $ A( JJ, JJ ), LDA, C( 1, JJ ), LDC, $ WORK, RWORK, INFO ) END IF END IF END IF RETURN * * End of CCNIIF * END SUBROUTINE CGRET( JOB, M, N, K, A, LDA, C, LDC, $ WORK, RWORK, INFO ) * * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, INFO * .. * .. Array Arguments .. COMPLEX A( LDA, * ), C( LDC, * ), WORK( * ) REAL RWORK( * ) * .. * * Purpose * ======= * * CGRET retriangularizes a special matrix. This has the following * features: its first column is non-zero and its main diagonal is zero * except the first element. Now it is showed a 4 by 8 small example: * x x x x x x x x * x 0 x x x x x x * x 0 0 x x x x x * x 0 0 0 x x x x * This subroutine assumes that in all cases N>=M. * The transformations applied to matrix A can be also * applied to matrix C. * * Parameters * ========== * * JOB (input) INTEGER * The job to do: * = 1: The transformations needed in the * triangularization are only applied to matrix A. * Thus, matrix C is not updated. * = 2: The same transformations needed in the * triangularization of matrix A are applied to * matrix C from the left. * That is, if Q'*A*P=R, then C := Q'*C. * In this case, matrix C is m-by-k. * = 3: The transpose of the transformations needed * in the triangularization of matrix A are applied * to matrix C from the right. * That is, if Q'*A*P=R, then C := C*Q. * In this case, matrix C is k-by-m. * In these three cases, the permutations are always stored * in vector JPVT. * * M (input) INTEGER * The number of rows of matrices A. M >= 0. * If JOB=2, M is the number of rows of matrix C. * If JOB=3, M is the number of columns of matrix C. * * N (input) INTEGER * The number of columns of matrix A. N >= 0. * * K (input) INTEGER * It defines the dimension of matrix C. K >= 0. * If JOB=2, K is the number of columns of matrix C. * If JOB=3, K is the number of rows of matrix C. * * A (input/output) COMPLEX array, dimension (LDA,N) * On entry, the m by n matrix A. * On exit, the upper triangle of the array contains the * min(m,n) by n upper trapezoidal matrix R; the lower triangle * array is filled with zeros. * * LDA (input) INTEGER * The leading dimension of array A. LDA >= max(1,M). * * C (input/output) COMPLEX array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the transformations * applied to matrix A are also applied to matrix C. * * LDC (input) INTEGER * The leading dimension of array C. * If JOB=2, then LDC >= MAX(1,M). * If JOB=3, then LDC >= MAX(1,K). * * WORK (workspace) COMPLEX array, dimension ( M ) * * RWORK (workspace) REAL array, dimension ( M ) * * INFO (output) INTEGER * = 0: Successful exit. * < 0: If info = -i, the i-th argument had an illegal value. * * ===================================================================== * * .. Parameters .. COMPLEX CZERO PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) ) * .. * .. Common Blocks .. INTEGER NB COMMON /BSPRQR/ NB * .. * .. Local Scalars .. INTEGER I, J, JB, ITEMP REAL COSINE COMPLEX R, SINE * .. * .. External Subroutines .. EXTERNAL CLARTG, CROT * .. * .. Intrinsic Functions .. INTRINSIC MIN, CONJG * .. * .. Executable Statements .. * INFO = 0 * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( M.EQ.1 ).OR.( N.EQ.0 ) ) $ RETURN IF( NB.GT.1 ) THEN * * Block Algorithm * =============== * * Compute Givens Rotations needed to nullify the first column * of matrix A and apply on the fly to that column. Store * temporally the sine and cosine of the angles of the applied * Givens Rotations in vectors WORK and RWORK. * DO 10 I = M, 2, -1 CALL CLARTG( A( I-1, 1 ), A( I, 1 ), $ RWORK( I ), WORK( I ), R ) A( I-1, 1 ) = R A( I, 1 ) = CZERO 10 CONTINUE * * Apply the previously computed Givens Rotations to the rest * of matrix A. * DO 20 J = 2, N, NB JB = MIN( NB, N-J+1 ) DO 30 I = MIN( M, J+JB-1 ), J, -1 CALL CROT( J+JB-I, A( I-1, I ), LDA, A( I, I ), LDA, $ RWORK( I ), WORK( I ) ) 30 CONTINUE DO 40 I = MIN( M, J-1 ), 2, -1 CALL CROT( JB, A( I-1, J ), LDA, A( I, J ), LDA, $ RWORK( I ), WORK( I ) ) 40 CONTINUE 20 CONTINUE * * Update the corresponding part of matrix C. * IF( ( JOB.EQ.2 ).AND.( K.GT.0 ) ) THEN * * Apply the previously computed rotations from the left. * DO 50 J = 1, K, NB JB = MIN( NB, K-J+1 ) DO 60 I = M, 2, -1 CALL CROT( JB, C( I-1, J ), LDC, C( I, J ), LDC, $ RWORK( I ), WORK( I ) ) 60 CONTINUE 50 CONTINUE ELSE IF( ( JOB.EQ.3 ).AND.( K.GT.0 ) ) THEN * * Apply the transpose of the previously computed rotations * from the right. * DO 70 I = M, 2, -1 CALL CROT( K, C( 1, I-1 ), 1, C( 1, I ), 1, $ RWORK( I ), CONJG( WORK( I ) ) ) 70 CONTINUE END IF ELSE * * Non-Block Algorithm * =================== * DO 90 I = M, 2, -1 ITEMP = I - 1 * * Compute the rotation parameters and update column 1 of A. * CALL CLARTG( A( ITEMP, 1 ), A( I , 1 ), COSINE, SINE, R ) A( ITEMP, 1 ) = R A( I, 1 ) = CZERO * * Update columns I:N of matrix A. * CALL CROT( N-I+1, A( ITEMP, I ), LDA, A( I, I ), LDA, $ COSINE, SINE ) * * Update the corresponding part of matrix C. * IF( ( JOB.EQ.2 ).AND.( K.GT.0 ) ) THEN * * Apply the previously computed rotations from the left. * CALL CROT( K, C( ITEMP, 1 ), LDC, C( I, 1 ), LDC, $ COSINE, SINE ) ELSE IF( ( JOB.EQ.3 ).AND.( K.GT.0 ) ) THEN * * Apply the transpose of the previously computed rotations * from the right. * CALL CROT( K, C( 1, ITEMP ), 1, C( 1, I ), 1, $ COSINE, CONJG( SINE ) ) END IF 90 CONTINUE END IF RETURN * * End of CGRET * END SUBROUTINE CHESS( JOB, M, N, K, A, LDA, C, LDC, $ WORK, RWORK, INFO ) * * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, INFO * .. * .. Array Arguments .. COMPLEX A( LDA, * ), C( LDC, * ), WORK( * ) REAL RWORK( * ) * .. * * Purpose * ======= * * CHESS reduces the upper hessemberg matrix A to upper triangular form. * applied to matrix C if argument JOB asks. * This subroutine assumes that in all cases N>=M. * * Parameters * ========== * * JOB (input) INTEGER * The job to do: * = 1: The transformations needed in the * triangularization are only applied to matrix A. * Thus, matrix C is not updated. * = 2: The same transformations needed in the * triangularization of matrix A are applied to * matrix C from the left. * That is, if Q'*A*P=R, then C := Q'*C. * In this case, matrix C is m-by-k. * = 3: The transpose of the transformations needed * in the triangularization of matrix A are applied * to matrix C from the right. * That is, if Q'*A*P=R, then C := C*Q. * In this case, matrix C is k-by-m. * In these three cases, the permutations are always stored * in vector JPVT. * * M (input) INTEGER * The number of rows of matrices A. M >= 0. * If JOB=2, M is the number of rows of matrix C. * If JOB=3, M is the number of columns of matrix C. * * N (input) INTEGER * The number of columns of matrix A. N >= 0. * * K (input) INTEGER * It defines the dimension of matrix C. K >= 0. * If JOB=2, K is the number of columns of matrix C. * If JOB=3, K is the number of rows of matrix C. * * A (input/output) COMPLEX array, dimension (LDA,N) * On entry, the m by n matrix A. * On exit, the upper triangle of the array contains the * min(m,n) by n upper trapezoidal matrix R; the lower triangle * array is filled with zeros. * * LDA (input) INTEGER * The leading dimension of array A. LDA >= max(1,M). * * C (input/output) COMPLEX array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the transformations * applied to matrix A are also applied to matrix C. * * LDC (input) INTEGER * The leading dimension of array C. * If JOB=2, then LDC >= MAX(1,M). * If JOB=3, then LDC >= MAX(1,K). * * WORK (workspace) COMPLEX array, dimension ( M ) * * RWORK (workspace) REAL array, dimension ( M ) * * INFO (output) INTEGER * = 0: Successful exit. * < 0: If info = -i, the i-th argument had an illegal value. * * ===================================================================== * * .. Parameters .. COMPLEX CZERO PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) ) * .. * .. Common Blocks .. INTEGER NB COMMON /BSPRQR/ NB * .. * .. Local Scalars .. INTEGER I, J, ITEMP, JB REAL COSINE COMPLEX R, SINE * .. * .. External Subroutines .. EXTERNAL CLARTG, CROT * .. * .. Intrinsic Functions .. INTRINSIC MIN, CONJG * .. * .. Executable Statements .. * INFO = 0 * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( M.EQ.1 ).OR.( N.EQ.0 ) ) $ RETURN IF( NB.GT.1 ) THEN * * Block Algorithm * =============== * * Compute Givens Rotations needed to reduce upper hessenberg * matrix A to triangular form, and apply on the fly those * rotations to matrix. Store temporally the sine and cosine * of the angles of the applied Givens Rotations in * vectors WORK and RWORK. * DO 10 J = 1, N, NB JB = MIN( NB, N-J+1 ) DO 20 I = 2, MIN( M, J ) CALL CROT( JB, A( I-1, J ), LDA, A( I, J ), LDA, $ RWORK( I ), WORK( I ) ) 20 CONTINUE DO 30 I = J+1, MIN( M, J+JB ) ITEMP = I-1 CALL CLARTG( A( ITEMP, ITEMP ), A( I, ITEMP ), $ RWORK( I ), WORK( I ), R ) A( ITEMP, ITEMP ) = R A( I, ITEMP ) = CZERO CALL CROT( J+JB-I, A( ITEMP, I ), LDA, $ A( I, I ), LDA, RWORK( I ), WORK( I ) ) 30 CONTINUE 10 CONTINUE * * Update the corresponding part of matrix C. * IF( ( JOB.EQ.2 ).AND.( K.GT.0 ) ) THEN * * Apply the previously computed rotations from the left. * DO 40 J = 1, K, NB JB = MIN( NB, K-J+1 ) DO 50 I = 2, M CALL CROT( JB, C( I-1, J ), LDC, C( I, J ), LDC, $ RWORK( I ), WORK( I ) ) 50 CONTINUE 40 CONTINUE ELSE IF( ( JOB.EQ.3 ).AND.( K.GT.0 ) ) THEN * * Apply the transpose of the previously computed rotations * from the right. * DO 60 I = 2, M CALL CROT( K, C( 1, I-1 ), 1, C( 1, I ), 1, $ RWORK( I ), CONJG( WORK( I ) ) ) 60 CONTINUE END IF ELSE * * Non-Block Algorithm * =================== * DO 80 I = 2, M ITEMP = I - 1 * * Compute the rotation parameters. * CALL CLARTG( A( ITEMP, ITEMP ), A( I, ITEMP ), $ COSINE, SINE, R ) * * Update columns I-1:N of matrix A. * A( ITEMP, ITEMP ) = R A( I, ITEMP ) = CZERO CALL CROT( N-I+1, A( ITEMP, I ), LDA, A( I, I ), LDA, $ COSINE, SINE ) * * Update the corresponding part of matrix C. * IF( ( JOB.EQ.2 ).AND.( K.GT.0 ) ) THEN * * Apply the previously computed rotations from the left. * CALL CROT( K, C( ITEMP, 1 ), LDC, C( I, 1 ), LDC, $ COSINE, SINE ) ELSE IF( ( JOB.EQ.3 ).AND.( K.GT.0 ) ) THEN * * Apply the transpose of the previously computed rotations * from the right. * CALL CROT( K, C( 1, ITEMP ), 1, C( 1, I ), 1, $ COSINE, CONJG( SINE ) ) END IF 80 CONTINUE END IF RETURN * * End of CHESS * END SHAR_EOF fi # end of overwriting check if test -f 'ctrqyc.f' then echo shar: will not over-write existing file "'ctrqyc.f'" else cat << SHAR_EOF > 'ctrqyc.f' SUBROUTINE CTRQYC( JOB, M, N, K, A, LDA, C, LDC, JPVT, RANK, $ SVLUES, RCNR, RCNRP1, WORK, RWORK, INFO ) * * This code is part of a release of the package for computing * rank-revealing QR Factorizations written by: * ================================================================== * Christian H. Bischof and Gregorio Quintana-Orti * Math. and Comp. Sci. Div. Departamento de Informatica * Argonne National Lab. Universidad Jaime I * Argonne, IL 60439 Campus P. Roja, 12071 Castellon * USA Spain * bischof@mcs.anl.gov gquintan@inf.uji.es * ================================================================== * $Revision: 1.42 $ * $Date: 96/12/30 16:59:44 $ * * .. Scalars Arguments .. INTEGER JOB, M, N, K, LDA, LDC, RANK, INFO REAL RCNR, RCNRP1 * .. * .. Array Arguments .. COMPLEX A( LDA, * ), C( LDC, * ), WORK( * ) REAL SVLUES( 4 ), RWORK( * ) INTEGER JPVT( * ) * .. * * Purpose * ======= * * PREC_TRQYC carries out Pan-Tang Algorithm 3 for the stage RANK. * This is a mofified version of the original algorithm. The improved * features are the following: * o Use of Bischof's ICE to reduce the computational cost. * o Reorganization of the main loop to save computations. * o No permutation is carried out if not strictly needed. * * Arguments * ========= * * JOB (input) INTEGER * The job to do: * = 1: The orthogonal transformations needed in the * triangularization are only applied to matrix A. * Thus, matrix C is not updated. * = 2: The same orthogonal transformations needed in the * triangularization of matrix A are applied to * matrix C from the left. * That is, if Q'*A*P=R, then C := Q'*C. * In this case, matrix C is m-by-k. * = 3: The transpose of the orthogonal transformations needed * in the triangularization of matrix A are applied * to matrix C from the right. * That is, if Q'*A*P=R, then C := C*Q. * In this case, matrix C is k-by-m. * In these three cases, the permutations are always stored * in vector JPVT. * * M (input) INTEGER * The number of rows of matrices A and C. M >= 0. * * N (input) INTEGER * The number of columns of matrix A. N >= 0. * * K (input) INTEGER * The number of columns of matrix C. K >= 0. * * A (input/output) COMPLEX array (LDA,N) * Upper triangular m by n matrix. * * LDA (input) INTEGER * The leading dimension of array A. LDA >= MAX( 1, M ). * * C (input/output) COMPLEX array (LDC,K) * Matrix of dimension m x k where to accumulate * orthogonal transformations from the left. * * LDC (input) INTEGER * The leading dimension of array C. LDC >= MAX( 1, M ). * * JPVT (input/output) INTEGER array (N) * Vector with the actual permutation of matrix A. * * RANK (input) INTEGER * The estimate for the rank. 1 <= RANK <= MIN(M,N). * * SVLUES (output) REAL array, dimension (4) * On exit, SVLUES contains estimates of some of the singular * values of the triangular factor R. * SVLUES(1): largest singular value of R(1:RANK,1:RANK) * SVLUES(2): smallest singular value of R(1:RANK,1:RANK) * SVLUES(3): smallest singular value of R(1:RANK+1,1:RANK+1) * SVLUES(4): smallest singular value of R * If the triangular factorization is a rank-revealing one * (which will be the case if the leading columns were well- * conditioned), then SVLUES(1) will also be an estimate * for the largest singular value of A, SVLUES(2) and SVLUES(3) * will be estimates for the RANK-th and (RANK+1)-st singular * value of A, and SVLUES(4) will be an estimate for the * smallest singular value of A. * By examining these values, one can confirm that the rank is * well defined with respect to the threshold chosen. * * RCNR (output) REAL * The estimate for the inverse of the condition number of * block R(1:RANK,1:RANK). * * RCNRP1 (output) REAL * The estimate for the inverse of the condition number of * block R(1:RANK+1,1:RANK+1). * * WORK (workspace) COMPLEX array, dimension (2*MIN(M,N)) * * RWORK (workspace) REAL array, dimension (N+MIN(M,N)) * * INFO (output) INTEGER * = 0: Successful exit. * < 0: If info = -i, the i-th argument had an illegal value. * = 4: Exceeded the allowed maximum number of steps. That is, * the matrix presents a slow convergence. * * * Further Details * =============== * * If the leading block of R is singular or near singular, there will * be no permutation because in that case the right (and left) singular * vectors are the canonical ones ((0,0,...0,1)^T). * That is, there will not be permutation if * RCOND <= SF * SLAMCH('Safe Minimum'), where SF (Safe Factor) is * a security factor to avoid arithmetic exceptions. * * ===================================================================== * * .. Parameters .. REAL FP, SF COMPLEX CONE PARAMETER ( FP = 0.9E+0, SF = 1.0E+2, $ CONE = ( 1.0E+0, 0.0E+0 ) ) * * Indices into the 'svlues' array. * INTEGER IMAX, IBEFOR, IAFTER, IMIN PARAMETER ( IMAX = 1, IBEFOR = 2, IAFTER = 3, IMIN = 4 ) * .. * .. Local Scalars .. INTEGER I, II, ITEMP, J, JJ, MN, MXSTPS, NCA, NCTBA REAL F, RCOS, SMAX, SMAXPR, SMIN, SMINPR, SMXRP1, $ SMNRP1, TEMP COMPLEX COSINE, CTEMP, DIAG, SINE INTEGER NS * .. Local Arrays .. COMPLEX CDUMMY( 1, 1 ) * .. * .. External Subroutines .. EXTERNAL CCOPY, CGRET, CHESS, CLAIC1, $ CLARTG, CSCAL, CSWAP, CTRSV * .. * .. External Functions .. EXTERNAL ISAMAX, ICAMAX, SLAMCH, $ SLASMX, SCNRM2 INTEGER ISAMAX, ICAMAX REAL SLAMCH, SLASMX, SCNRM2 * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT, REAL * .. * .. Executable Statements .. MN = MIN( M, N ) MXSTPS = N+25 NS = 0 * * Test input arguments * ==================== * INFO = 0 IF( ( JOB.LT.1 ).OR.( JOB.GT.3 ) ) THEN INFO = -1 ELSE IF( M.LT.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( K.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -6 ELSE IF( ( ( JOB.EQ.1 ).AND.( LDC.LT.1 ) ).OR. $ ( ( JOB.EQ.2 ).AND.( LDC.LT.MAX( 1, M ) ) ).OR. $ ( ( JOB.EQ.3 ).AND.( LDC.LT.MAX( 1, K ) ) ) ) THEN INFO = -8 ELSE IF( ( RANK.LT.1 ).OR.( RANK.GT.MN ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CTRQYC', -INFO ) RETURN END IF * * Quick return if possible. * IF( MN.EQ.0 ) $ RETURN * IF( RANK.EQ.MN ) THEN * * ************************ * ************************ * * Apply Chan Algorithm * * ************************ * ************************ * F = FP * * Move the best column of A(1:M,M:N) to position M-th. * JJ = MN - 1 + ICAMAX( N-MN+1, A( MN, MN ), LDA ) IF( JJ.GT.MN ) THEN CALL CSWAP( M, A( 1, MN ), 1, A( 1, JJ ), 1 ) ITEMP = JPVT( MN ) JPVT( MN ) = JPVT( JJ ) JPVT( JJ ) = ITEMP END IF * * Estimation of the largest singular value, the smallest * singular value, and its corresponding left singular vector. * SMAX = ABS( A( 1, 1 ) ) WORK( 1 ) = CONE SMIN = SMAX WORK( MN+1 ) = CONE DO 10 J = 2, RANK CALL CLAIC1( 1, J-1, WORK( 1 ), SMAX, A( 1, J ), $ A( J, J ), SMAXPR, SINE, COSINE ) CALL CSCAL( J-1, SINE, WORK( 1 ), 1 ) WORK( J ) = COSINE SMAX = SMAXPR * CALL CLAIC1( 2, J-1, WORK( MN+1 ), SMIN, A( 1, J ), $ A( J, J ), SMINPR, SINE, COSINE ) CALL CSCAL( J-1, SINE, WORK( MN+1 ), 1 ) WORK( MN+J ) = COSINE SMIN = SMINPR 10 CONTINUE * * Determine if matrix A is singular or nearly singular. * SF (Safe Factor) is used to say whether or not it is. * IF( SMIN.GT.( SMAX*SF*SLAMCH( 'Safe Minimum' ) ) ) THEN * * Matrix is not singular or not nearly singular. * Follow usual method: Estimate the right singular vector * corresponding to the smallest singular value of upper * triangular block A(1:RANK,1:RANK). * CALL CTRSV( 'Upper', 'No transpose', 'No unit', $ RANK, A, LDA, WORK( MN+1 ), 1 ) * * Find the index with largest absolute value in vector * WORK( MN+1:2*MN ). * JJ = ICAMAX( RANK, WORK( MN+1 ), 1 ) * * Permut if necessary. * IF( ( JJ.LT.RANK ).AND.( ( ABS( WORK( MN+JJ ) )*F ) $ .GT.ABS( WORK( MN+RANK ) ) ) ) THEN * NS = 1 * * Exchange cyclically to the left the columns of A between * JJ and RANK, that is: JJ->RANK, JJ+1->JJ, JJ+2->JJ+1,..., * RANK->RANK-1. * CALL CCOPY( RANK, A( 1, JJ ), 1, WORK( 1 ), 1 ) DO 20 J = JJ+1, RANK CALL CCOPY( J, A( 1, J ), 1, A( 1, J-1 ), 1 ) 20 CONTINUE CALL CCOPY( RANK, WORK( 1 ), 1, A( 1, RANK ), 1 ) * * Exchange in the same way vector JPVT. * ITEMP = JPVT( JJ ) DO 30 J = JJ+1, RANK JPVT( J-1 ) = JPVT( J ) 30 CONTINUE JPVT( RANK ) = ITEMP * * Retriangularization of matrix A after the permutation. * IF( JOB.EQ.1 ) THEN CALL CHESS( JOB, RANK-JJ+1, N-JJ+1, K, $ A( JJ, JJ ), LDA, CDUMMY, 1, $ WORK( 1 ), RWORK( N+1 ), INFO ) ELSE IF( JOB.EQ.2 ) THEN CALL CHESS( JOB, RANK-JJ+1, N-JJ+1, K, $ A( JJ, JJ ), LDA, C( JJ, 1 ), LDC, $ WORK( 1 ), RWORK( N+1 ), INFO ) ELSE IF( JOB.EQ.3 ) THEN CALL CHESS( JOB, RANK-JJ+1, N-JJ+1, K, $ A( JJ, JJ ), LDA, C( 1, JJ ), LDC, $ WORK( 1 ), RWORK( N+1 ), INFO ) END IF END IF END IF * * Computation of the contents of vector SVLUES, RCNR and RCNRP1. * SVLUES( IMAX ) = SMAX SVLUES( IBEFOR ) = SMIN SVLUES( IAFTER ) = SMIN SVLUES( IMIN ) = SMIN RCNR = SVLUES( IBEFOR ) / SVLUES( IMAX ) RCNRP1 = RCNR ELSE * * *************************************** * *************************************** * * Apply Modified Pan&Tang Algorithm 3 * * *************************************** * *************************************** * * Adjust the value of f. * F = FP / SQRT( REAL( RANK+1 ) ) * * Compute the norms of columns of matrix A. Store them into * vector RWORK(1:N). * DO 100 J = 1, N RWORK( J ) = SCNRM2( MIN( M, J ), A( 1, J ), 1 ) 100 CONTINUE * * Estimate the smallest singular value of A(1:RANK,1:RANK) and * its corresponding left singular vector. * SMIN will contain the smallest singular value and * WORK(1:MN) will contain the left singular vector. * SMIN = ABS( A( 1, 1 ) ) WORK( 1 ) = CONE DO 110 J = 2, RANK CALL CLAIC1( 2, J-1, WORK( 1 ), SMIN, A( 1, J ), $ A( J , J ), SMINPR, SINE, COSINE ) CALL CSCAL( J-1, SINE, WORK( 1 ), 1 ) WORK( J ) = COSINE SMIN = SMINPR 110 CONTINUE * * Initialize loop variables. * NCA = 0 NCTBA = N-RANK II = RANK+1 * * *********************** * * Start of Loop WHILE * * *********************** * 1000 IF( ( NCA.LT.NCTBA ).AND.( NS.LT.MXSTPS ) ) THEN * * Estimate the smallest singular value of A(1:RANK+1,1:RANK+1) * and its corresponding left singular vector as if column II * of matrix A were on column RANK+1. * DIAG = A( MIN( MN, II ), II ) DO 120 I = MIN( MN, II )-1, RANK+1, -1 CALL CLARTG( A( I, II ), DIAG, RCOS, SINE, CTEMP ) DIAG = CTEMP 120 CONTINUE * CALL CLAIC1( 2, RANK, WORK( 1 ), SMIN, A( 1, II ), $ DIAG, SMNRP1, SINE, COSINE ) IF( SMNRP1.GE.( F*ABS( DIAG ) ) ) THEN * * Column II accepted on the right part of matrix A. * NCA = NCA+1 IF( II.EQ.N ) THEN II = RANK+1 ELSE II = II+1 END IF ELSE * * Column II not accepted on the right part of matrix A. * * *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* * * Permut column II to position RANK+1 * * *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* * * Exchange cyclically to the right the columns of A between * RANK+1 and II, that is, RANK+1->RANK+2, RANK+2->RANK+3, * ...,II-1->II,II->RANK+1. * CALL CCOPY( MIN( MN, II ), A( 1, II ), 1, $ WORK( MN+1 ), 1 ) DO 130 J = II-1, RANK+1, -1 CALL CCOPY( MIN( MN, J+1 ), A( 1, J ), 1 , $ A( 1, J+1 ), 1 ) 130 CONTINUE CALL CCOPY( MIN( MN, II ), WORK( MN+1 ), 1, $ A( 1, RANK+1 ), 1 ) * * Exchange in the same way vector JPVT. * ITEMP = JPVT( II ) DO 140 J = II-1, RANK+1, -1 JPVT( J+1 ) = JPVT( J ) 140 CONTINUE JPVT( RANK+1 ) = ITEMP * * Exchange in the same way vector RWORK(1:N). * TEMP = RWORK( II ) DO 150 J = II-1, RANK+1, -1 RWORK( J+1 ) = RWORK( J ) 150 CONTINUE RWORK( RANK+1 ) = TEMP * * Retriangularize matrix A after permutation. * IF( JOB.EQ.1 ) THEN CALL CGRET( JOB, MIN( M, II )-RANK, N-RANK, K, $ A( RANK+1, RANK+1 ), LDA, CDUMMY, 1, $ WORK( MN+1 ), RWORK( N+1 ), INFO ) ELSE IF( JOB.EQ.2 ) THEN CALL CGRET( JOB, MIN( M, II )-RANK, N-RANK, K, $ A( RANK+1, RANK+1 ), LDA, C( RANK+1, 1 ), $ LDC, WORK( MN+1 ), RWORK( N+1 ), INFO ) ELSE IF( JOB.EQ.3 ) THEN CALL CGRET( JOB, MIN( M, II )-RANK, N-RANK, K, $ A( RANK+1, RANK+1 ), LDA, C( 1, RANK+1 ), $ LDC, WORK( MN+1 ), RWORK( N+1 ), INFO ) END IF * * Estimate the largest singular value. * ITEMP = ISAMAX( RANK+1, RWORK, 1 ) SMXRP1 = SLASMX( RANK+1 )*RWORK( ITEMP ) * * *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* * * Estimate the right singular vector * * *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* * IF( SMNRP1.GT. $ ( SMXRP1*SF*SLAMCH( 'Safe minimum' ) ) ) THEN * * Matrix is not singular or not nearly singular. * * First, end the estimation of the left singular vector. * No problem to access WORK(MN+RANK+1) since RANKRANK+1,JJ+1->JJ, * JJ+2->JJ+1,...,RANK+1->RANK. * CALL CCOPY( RANK+1, A( 1, JJ ), 1, $ WORK( MN+1 ), 1 ) DO 160 J = JJ+1, RANK+1 CALL CCOPY( J, A( 1, J ), 1, $ A( 1, J-1 ), 1 ) 160 CONTINUE CALL CCOPY( RANK+1, WORK( MN+1 ), 1, $ A( 1, RANK+1 ), 1 ) * * Exchange in the same way vector JPVT. * ITEMP = JPVT( JJ ) DO 170 J = JJ+1, RANK+1 JPVT( J-1 ) = JPVT( J ) 170 CONTINUE JPVT( RANK+1 ) = ITEMP * * Exchange in the same way vector RWORK. * TEMP = RWORK( JJ ) DO 180 J = JJ+1, RANK+1 RWORK( J-1 ) = RWORK( J ) 180 CONTINUE RWORK( RANK+1 ) = TEMP * * Retriangularize matrix A after the permutation. * IF( JOB.EQ.1 ) THEN CALL CHESS( JOB, RANK-JJ+2, N-JJ+1, K, $ A( JJ, JJ ), LDA, CDUMMY, 1, $ WORK( MN+1 ), RWORK( N+1 ), INFO ) ELSE IF( JOB.EQ.2 ) THEN CALL CHESS( JOB, RANK-JJ+2, N-JJ+1, K, $ A( JJ, JJ ), LDA, C( JJ, 1 ), LDC, $ WORK( MN+1 ), RWORK( N+1 ), INFO ) ELSE IF( JOB.EQ.3 ) THEN CALL CHESS( JOB, RANK-JJ+2, N-JJ+1, K, $ A( JJ, JJ ), LDA, C( 1, JJ ), LDC, $ WORK( MN+1 ), RWORK( N+1 ), INFO ) END IF * * Estimate the smallest singular value of * A(1:RANK,1:RANK) and its corresponding left * singular vector. * SMIN will contain the smallest singular value and * WORK(1:MN) will contain the left singular * vector. * SMIN = ABS( A( 1, 1 ) ) WORK( 1 ) = CONE DO 190 J = 2, RANK CALL CLAIC1( 2, J-1, WORK( 1 ), SMIN, $ A( 1, J ), A( J , J ), SMINPR, $ SINE, COSINE ) CALL CSCAL( J-1, SINE, WORK( 1 ), 1 ) WORK( J ) = COSINE SMIN = SMINPR 190 CONTINUE END IF END IF * * Update loop variables. * NCA = 0 NS = NS+1 IF( II.EQ.N ) THEN II = RANK+1 ELSE II = II+1 END IF END IF GOTO 1000 END IF * * ********************* * * End of Loop WHILE * * ********************* * * ****************** * * Final Pivoting * * ****************** * * Exchange column in R(RANK+1:M,RANK+1:N) with largest norm to * position RANK+1. * JJ = RANK+ISAMAX( N-RANK, RWORK( RANK+1 ), 1 ) IF( ( JJ.GT.( RANK+1 ) ).AND. $ ( F*ABS( RWORK( JJ ) ).GT.ABS( RWORK( RANK+1 ) ) ) ) THEN * * Exchange column JJ to position RANK+1. * CALL CCOPY( MIN( MN, JJ ), A( 1, JJ ), 1, $ WORK( MN+1 ), 1 ) DO 200 J = JJ-1, RANK+1, -1 CALL CCOPY( MIN( MN, J+1 ), A( 1, J ), 1 , $ A( 1, J+1 ), 1 ) 200 CONTINUE CALL CCOPY( MIN( MN, JJ ), WORK( MN+1 ), 1, $ A( 1, RANK+1 ), 1 ) * * Exchange in the same way vector JPVT. * ITEMP = JPVT( JJ ) DO 210 J = JJ-1, RANK+1, -1 JPVT( J+1 ) = JPVT( J ) 210 CONTINUE JPVT( RANK+1 ) = ITEMP * * Retriangularize matrix A after permutation. * IF( JOB.EQ.1 ) THEN CALL CGRET( JOB, MIN( M, JJ )-RANK, N-RANK, K, $ A( RANK+1, RANK+1 ), LDA, CDUMMY, 1, $ WORK( MN+1 ), RWORK( N+1 ), INFO ) ELSE IF( JOB.EQ.2 ) THEN CALL CGRET( JOB, MIN( M, JJ )-RANK, N-RANK, K, $ A( RANK+1, RANK+1 ), LDA, C( RANK+1, 1 ), $ LDC, WORK( MN+1 ), RWORK( N+1 ), INFO ) ELSE IF( JOB.EQ.3 ) THEN CALL CGRET( JOB, MIN( M, JJ )-RANK, N-RANK, K, $ A( RANK+1, RANK+1 ), LDA, C( 1, RANK+1 ), $ LDC, WORK( MN+1 ), RWORK( N+1 ), INFO ) END IF END IF * * ************************************************************** * * Computation of vector SVLUES and variables RCNR and RCNRP1 * * ************************************************************** * * Computation of the largest singular value of A(1:RANK,1:RANK). * SMAX = ABS( A( 1, 1 ) ) WORK( MN+1 ) = CONE * DO 220 J = 2, RANK CALL CLAIC1( 1, J-1, WORK( MN+1 ), SMAX, $ A( 1, J ), A( J, J ), SMAXPR, SINE, COSINE ) CALL CSCAL( J-1, SINE, WORK( MN+1 ), 1 ) WORK( MN+J ) = COSINE SMAX = SMAXPR 220 CONTINUE SVLUES( IMAX ) = SMAX SVLUES( IBEFOR ) = SMIN * * Computation of the largest singular value and the smallest * singular value of A(1:RANK+1,1:RANK+1). * CALL CLAIC1( 1, RANK, WORK( MN+1 ), SMAX, $ A( 1, RANK+1 ), A( RANK+1, RANK+1 ), SMXRP1, $ SINE, COSINE ) CALL CLAIC1( 2, RANK, WORK( 1 ), SMIN, $ A( 1, RANK+1 ), A( RANK+1, RANK+1 ), SMINPR, $ SINE, COSINE ) CALL CSCAL( RANK, SINE, WORK( 1 ), 1 ) WORK( RANK+1 ) = COSINE SMIN = SMINPR SVLUES( IAFTER ) = SMIN * * Computation of the smallest singular value of A(1:MN,1:MN). * DO 230 J = RANK+2, MN CALL CLAIC1( 2, J-1, WORK( 1 ), SMIN, $ A( 1, J ), A( J, J ), SMINPR, SINE, COSINE ) CALL CSCAL( J-1, SINE, WORK( 1 ), 1 ) WORK( J ) = COSINE SMIN = SMINPR 230 CONTINUE SVLUES( IMIN ) = SMIN * * Computation of RCNR and RCNRP1. * RCNR = SVLUES( IBEFOR ) / SVLUES( IMAX ) RCNRP1 = SVLUES( IAFTER ) / SMXRP1 * IF( NS.GE.MXSTPS ) THEN INFO = 1 END IF END IF RETURN * * End of CTRQYC * END SHAR_EOF fi # end of overwriting check if test -f 'ctrrnk.f' then echo shar: will not over-write existing file "'ctrrnk.f'" else cat << SHAR_EOF > 'ctrrnk.f' SUBROUTINE CTRRNK( N, R, LDR, RCOND, RANK, WORK, INFO ) * * $Revision: 1.42 $ * $Date: 96/12/30 16:59:45 $ * * .. Scalar Arguments .. INTEGER LDR, N, RANK, INFO REAL RCOND * .. * .. Array Arguments .. COMPLEX R( LDR, * ), WORK( * ) * * Purpose * ======= * * CTRRNK computes an estimate for the numerical rank of a * triangular n-by-n matrix R. * * Arguments * ========= * * N (input) INTEGER * Number of rows and columns of the matrix R. N >= 0. * * R (input) COMPLEX array, dimension (LDR,N) * On entry, the n by n matrix R. * * LDR (input) INTEGER * The leading dimension of the array R. LDR >= max(1,N). * * RCOND (input) REAL * Threshold value for the numerical rank. * * RANK (output) INTEGER * Numerical rank for threshold RCOND. * * WORK (workspace) COMPLEX array, dimension (2*N) * * INFO (output) INTEGER * = 0: Successful exit. * < 0: If INFO = -i, the i-th argument had an illegal value. * * ===================================================================== * * .. Parameters .. COMPLEX CONE REAL ZERO * .. * .. Local Scalars .. INTEGER I REAL SMAX, SMAXPR, SMIN, SMINPR COMPLEX C1, C2, S1, S2 * .. * .. External Subroutines .. EXTERNAL CLAIC1 * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. Executable statements .. * * Test the input arguments * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 ELSE IF( LDR.LT.MAX( 1, N ) ) THEN INFO = -3 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CTRRNK', -INFO ) RETURN END IF * * Determine RANK using incremental condition estimation. * WORK( 1 ) = CONE WORK( N+1 ) = CONE SMAX = ABS( R( 1, 1 ) ) SMIN = SMAX IF( ABS( R( 1, 1 ) ).EQ.ZERO ) THEN RANK = 0 GO TO 30 ELSE RANK = 1 END IF * 10 CONTINUE IF( RANK.LT.N ) THEN I = RANK + 1 CALL CLAIC1( 2, RANK, WORK, SMIN, R( 1, I ), $ R( I, I ), SMINPR, S1, C1 ) CALL CLAIC1( 1, RANK, WORK( N+1 ), SMAX, R( 1, I ), $ R( I, I ), SMAXPR, S2, C2 ) * IF( ( SMAXPR*RCOND ).LE.SMINPR ) THEN DO 20 I = 1, RANK WORK( I ) = S1*WORK( I ) WORK( N+I ) = S2*WORK( N+I ) 20 CONTINUE WORK( RANK+1 ) = C1 WORK( N+RANK+1 ) = C2 SMIN = SMINPR SMAX = SMAXPR RANK = RANK + 1 GO TO 10 END IF END IF 30 CONTINUE * RETURN * * End of CTRRNK * END SHAR_EOF fi # end of overwriting check if test -f 'zgeqpb.f' then echo shar: will not over-write existing file "'zgeqpb.f'" else cat << SHAR_EOF > 'zgeqpb.f' SUBROUTINE ZGEQPB( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ IRCOND, ORCOND, RANK, SVLUES, WORK, LWORK, $ RWORK, INFO ) * * This code is part of a release of the package for computing * rank-revealing QR Factorizations written by: * ================================================================== * Christian H. Bischof and Gregorio Quintana-Orti * Math. and Comp. Sci. Div. Departamento de Informatica * Argonne National Lab. Universidad Jaime I * Argonne, IL 60439 Campus P. Roja, 12071 Castellon * USA Spain * bischof@mcs.anl.gov gquintan@inf.uji.es * ================================================================== * $Revision: 1.42 $ * $Date: 96/12/30 16:59:36 $ * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, RANK, LWORK, INFO DOUBLE PRECISION IRCOND, ORCOND * .. * .. Array Arguments .. INTEGER JPVT( * ) COMPLEX*16 A( LDA, * ), C( LDC, * ), WORK( * ) DOUBLE PRECISION SVLUES( 4 ), RWORK( * ) * .. * * Purpose * ======= * * ZGEQPB computes a QR factorization * A*P = Q*[ R11 R12 ] * [ 0 R22 ] * of a real m by n matrix A. The permutation P is * chosen with the goal to reveal the rank of A by a * suitably dimensioned trailing submatrix R22 with norm(R22) * being small. * * Arguments * ========= * * JOB (input) INTEGER * The job to do: * = 1: The transformations needed in the * triangularization are only applied to matrix A. * Thus, matrix C is not updated. * = 2: The same transformations needed in the * triangularization of matrix A are applied to * matrix C from the left. * That is, if Q'*A*P=R, then C := Q'*C. * In this case, matrix C is m-by-k. * = 3: The transpose of the transformations needed * in the triangularization of matrix A are applied * to matrix C from the right. * That is, if Q'*A*P=R, then C := C*Q. * In this case, matrix C is k-by-m. * In these three cases, the permutations are always saved * into vector JPVT. * * M (input) INTEGER * The number of rows of matrices A. M >= 0. * If JOB=2, M is the number of rows of matrix C. * If JOB=3, M is the number of columns of matrix C. * * N (input) INTEGER * The number of columns of matrix A. N >= 0. * * K (input) INTEGER * It defines the dimension of matrix C. K >= 0. * If JOB=2, K is the number of columns of matrix C. * If JOB=3, K is the number of rows of matrix C. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the m by n matrix A. * On exit, the upper triangle of the array contains the * min(m,n) by n upper trapezoidal matrix R; the lower triangle * array is filled with zeros. * * LDA (input) INTEGER * The leading dimension of array A. LDA >= MAX(1,M). * * C (input/output) COMPLEX*16 array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the transformations * applied to matrix A are also applied to matrix C. * * LDC (input) INTEGER * The leading dimension of array C. * If JOB=2, then LDC >= MAX(1,M). * If JOB=3, then LDC >= MAX(1,K). * * JPVT (output) INTEGER array, dimension (N) * JPVT(I) = K <==> Column K of A has been permuted into * position I in AP. * JPVT(1:RANK) contains the indices of the columns considered * linearly independent. * JPVT(RANK+1:N) contains the indices of the columns considered * linearly dependent from the previous ones. * * IRCOND (input) FLOATING_DECLARE * 1/IRCOND specifies an upper bound on the condition number * of R11. If IRCOND == 0, IRCOND = machine precision is chosen * as default. IRCOND must be >= 0. * * ORCOND (output) FLOATING_DECLARE * 1/ORCOND is an estimate for the condition number of R11. * * RANK (output) INTEGER * RANK is an estimate for the numerical rank of A with respect * to the threshold 1/IRCOND in the sense that * RANK = arg_max(cond_no(R(1:r,1:r))<1/IRCOND) * This may be an underestimate of the rank if the leading * columns were not well-conditioned. * * SVLUES (output) DOUBLE PRECISION array, dimension (4) * On exit, SVLUES contains estimates of some of the * singular values of the triangular factor R. * SVLUES(1): largest singular value of R(1:RANK,1:RANK) * SVLUES(2): smallest singular value of R(1:RANK,1:RANK) * SVLUES(3): smallest singular value of R(1:RANK+1,1:RANK+1) * SVLUES(4): smallest singular value of R * If the triangular factorization is a rank-revealing one * (which will be the case if the leading columns were well- * conditioned), then SVLUES(1) will also be an estimate * for the largest singular value of A, SVLUES(2) and SVLUES(3) * will be estimates for the RANK-th and (RANK+1)-st singular * value of A, and SVLUES(4) will be an estimate for the * smallest singular value of A. * By examining these values, one can confirm that the rank is * well defined with respect to the threshold chosen. * * WORK (workspace) COMPLEX*16 array, dimension (LWORK) * On exit: WORK(1) is the size of the storage array needed * for optimal performance * * LWORK (input) INTEGER * The dimension of array WORK. * If JOB=1: * The unblocked strategy requires that: * LWORK >= 2*MN+N. * The block algorithm requires that: * LWORK >= 2*MN+N*NB. * If JOB<>1: * The unblocked strategy requires that: * LWORK >= 2*MN+MAX(K,N). * The block algorithm requires that: * LWORK >= 2*MN+NB*NB+NB*MAX(K,N). * Where MN = min(M,N) and NB is the maximum of blocksize * used within xGEQRF and blocksize used within xUNMQR. * In both cases, the minimum required workspace is the * one for the unblocked strategy. * * RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) * * INFO (output) INTEGER * = 0: Successful exit * < 0: If INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO COMPLEX*16 CZERO PARAMETER ( ZERO = 0.0D+0, CZERO = ( 0.0D+0, 0.0D+0 ) ) INTEGER INB, INBMIN, IXOVER PARAMETER ( INB = 1, INBMIN = 2, IXOVER = 3 ) * * Indices into the 'svlues' array. * INTEGER IMAX, IBEFOR, IAFTER, IMIN PARAMETER ( IMAX = 1, IBEFOR = 2, IAFTER = 3, IMIN = 4 ) * .. * .. Local Scalars .. INTEGER I, J, MN, ITEMP, KK, LACPTD, MVIDX, STREJ, $ ACCPTD, NB, LWSIZE, NLLITY, KB, WSIZE, WKMIN DOUBLE PRECISION SMIN, MXNM, RCOND LOGICAL BLOCK * .. * .. External Subroutines .. EXTERNAL XERBLA, ZGEQPC, ZGEQPW, $ ZLARFT, ZLARFB * .. * .. External Functions .. INTEGER ILAENV DOUBLE PRECISION DLAMCH, DLASMX EXTERNAL ILAENV, DLAMCH, DLASMX * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN, DBLE, INT * .. * .. Executable Statements .. * MN = MIN( M, N ) * * Compute the minimum required complex workspace. * IF( JOB.EQ.1 ) THEN WKMIN = 2*MN + N ELSE WKMIN = 2*MN + MAX( N, K ) END IF * * Test input arguments * ==================== * INFO = 0 IF( ( JOB.LT.1 ).OR.( JOB.GT.3 ) ) THEN INFO = -1 ELSE IF( M.LT.0 ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( K.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -6 ELSE IF( ( ( JOB.EQ.1 ).AND.( LDC.LT.1 ) ).OR. $ ( ( JOB.EQ.2 ).AND.( LDC.LT.MAX( 1, M ) ) ).OR. $ ( ( JOB.EQ.3 ).AND.( LDC.LT.MAX( 1, K ) ) ) ) THEN INFO = -8 ELSE IF( IRCOND.LT.ZERO ) THEN INFO = -10 ELSE IF( LWORK.LT.MAX( 1, WKMIN ) ) THEN INFO = -15 END IF IF( ( INFO .EQ. 0 .OR. INFO .EQ. -15 ).AND. LWORK.GE.1 ) THEN * * Compute the optimal complex workspace. * IF( JOB.EQ.1 ) THEN NB = ILAENV( INB, 'ZGEQRF', ' ', M, N, 0, 0 ) WSIZE = 2*MN + MAX( 3*N, N*NB ) ELSE NB = MAX( ILAENV( INB, 'ZGEQRF', ' ', M, N, 0, 0 ), $ ILAENV( INB, 'ZUNMQR', ' ', M, N, 0, 0 ) ) WSIZE = MAX( 2*MN + MAX( N, K ), $ 2*MN + NB*NB + NB*MAX( N, K ) ) END IF WORK( 1 ) = DBLE( WSIZE ) END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGEQPB', -INFO ) RETURN END IF * * Initialization of vector JPVT. * DO 70 J = 1, N JPVT( J ) = J 70 CONTINUE * * Quick return if possible * IF( MN.EQ.0 ) THEN RANK = 0 ORCOND = ZERO SVLUES( IMAX ) = ZERO SVLUES( IBEFOR ) = ZERO SVLUES( IAFTER ) = ZERO SVLUES( IMIN ) = ZERO RETURN END IF * * Check whether Threshold for condition number was supplied. * If not, choose machine precision as default for RCOND. * IF( IRCOND.GT.ZERO ) THEN RCOND = IRCOND ELSE RCOND = DLAMCH( 'Epsilon' ) END IF * * Determine block size and whether to use blocked code at all * IF( LWORK.LT.WSIZE ) THEN IF( JOB.EQ.1 ) THEN NB = ( LWORK-2*MN )/N ELSE ITEMP = INT( SQRT( DBLE( $ MAX( K, N )**2+4*LWORK-8*MN ) ) ) NB = ( ITEMP-MAX( K, N ) )/2 END IF END IF * BLOCK = ( ( NB.GT.1 ).AND. $ ( NB.GE.ILAENV( INBMIN, 'ZGEQRF', ' ', M, N, 0, 0 ) ).AND. $ ( MN.GE.ILAENV( IXOVER, 'ZGEQRF', ' ', M, N, 0, 0 ) ) ) * * The size of the pivot window is chosen to be NB + NLLITY * for the blocked algorithm. * NLLITY = MIN( MN, MAX( 10, NB/2+(N*5)/100 ) ) * * *************************************************** * * Move column with largest residual norm up front * * *************************************************** * CALL ZGEQPC( JOB, M, N, K, A, LDA, C, LDC, 1, 0, $ RCOND, LACPTD, JPVT, WORK( 1 ), WORK( MN+1 ), $ SVLUES, MXNM, WORK( 2*MN+1 ), LWORK-2*MN, RWORK ) IF( LACPTD.EQ.1 ) THEN IF( LACPTD.EQ.MN ) THEN RANK = 1 ORCOND = SVLUES( IBEFOR )/SVLUES( IMAX ) GOTO 30 ELSE SMIN = SVLUES( IBEFOR ) END IF ELSE RANK = 0 ORCOND = ZERO SVLUES( IMAX ) = ZERO SVLUES( IBEFOR ) = ZERO SVLUES( IAFTER ) = ZERO SVLUES( IMIN ) = ZERO GOTO 30 END IF * * **************************** * * Factor remaining columns * * **************************** * IF( BLOCK ) THEN * * *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* * * Using blocked code with restricted pivoting strategy * * *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* * STREJ = N+1 KK = 2 * 10 IF( ( KK.GE.STREJ ).OR.( KK.GT.MN ) ) GOTO 20 * * invariant: A(:,KK) is the first column in currently * considered block column. * KB = MIN( NB, MIN( MN+1, STREJ )-KK ) * * The goal now is to find "KB" independent columns * among the remaining STREJ-KK not yet rejected columns. * LWSIZE = MIN( STREJ-KK, KB+NLLITY ) CALL ZGEQPW( M, LWSIZE, KB, KK-1, LACPTD, A, LDA, JPVT, $ RCOND, WORK( MN+1 ), SMIN, MXNM, $ WORK( 1 ), WORK( 2*MN+1 ), RWORK ) IF( LACPTD.GT.0 ) THEN * * Accumulate Householder vectors in a block reflector. * CALL ZLARFT( 'Forward', 'Columnwise', M-KK+1, $ LACPTD, A( KK, KK ), LDA, WORK( KK ), $ WORK( 2*MN+1 ), LACPTD ) * * Apply block reflector to A(KK:M,KK+LWSIZE:N). * IF( ( KK+LWSIZE ).LE.N ) THEN CALL ZLARFB( 'Left', 'Conjugate Transpose', $ 'Forward', 'Columnwise', $ M-KK+1, N-KK-LWSIZE+1, LACPTD, $ A( KK, KK ), LDA, $ WORK( 2*MN+1 ), LACPTD, $ A( KK, KK+LWSIZE ), LDA, $ WORK( 2*MN+LACPTD*LACPTD+1 ), $ N-KK-LWSIZE+1 ) END IF * * Apply block reflector to the corresponding part * of matrix C. * IF( ( JOB.EQ.2 ).AND.( K.GT.0 ) ) THEN * * Apply it to matrix C(KK:M,1:K) from the left. * CALL ZLARFB( 'Left', 'Conjugate Transpose', $ 'Forward', 'Columnwise', M-KK+1, K, $ LACPTD, A( KK, KK ), LDA, $ WORK( 2*MN+1 ), LACPTD, $ C( KK, 1 ), LDC, $ WORK( 2*MN+LACPTD*LACPTD+1 ), K ) ELSE IF( ( JOB.EQ.3 ).AND.( K.GT.0 ) ) THEN * * Apply the transpose of it to matrix C(1:K,KK:M) * from the right. * CALL ZLARFB( 'Right', 'No Transpose', 'Forward', $ 'Columnwise', K, M-KK+1, LACPTD, $ A( KK, KK ), LDA, $ WORK( 2*MN+1 ), LACPTD, $ C( 1, KK ), LDC, $ WORK( 2*MN+LACPTD*LACPTD+1 ), K ) END IF END IF * * Move rejected columns to the end if there is space. * IF( LACPTD.LT.KB ) THEN IF( STREJ.LE.( KK+LWSIZE ) ) THEN STREJ = KK + LACPTD ELSE MVIDX = STREJ DO 40 I = KK+LACPTD, $ MIN( KK+LWSIZE-1, STREJ-LWSIZE+LACPTD-1 ) MVIDX = MVIDX - 1 CALL ZSWAP( M, A( 1, I ),1, A( 1, MVIDX ),1 ) ITEMP = JPVT( I ) JPVT( I ) = JPVT( MVIDX ) JPVT( MVIDX ) = ITEMP 40 CONTINUE STREJ = MVIDX END IF END IF KK = KK + LACPTD GOTO 10 20 CONTINUE ACCPTD = KK-1 SVLUES( IMAX ) = DLASMX( ACCPTD )*MXNM SVLUES( IBEFOR ) = SMIN IF( ACCPTD.LT.MN ) THEN * * Process rejected columns. * CALL ZGEQPC( JOB, M, N, K, A, LDA, C, LDC, MN-KK+1, $ KK-1, RCOND, LACPTD, JPVT, WORK( 1 ), $ WORK( MN+1 ), SVLUES, MXNM, WORK( 2*MN+1 ), $ LWORK-2*MN, RWORK ) RANK = ACCPTD + LACPTD ELSE RANK = ACCPTD SVLUES( IAFTER ) = SMIN SVLUES( IMIN ) = SMIN END IF ELSE * * *-*-*-*-*-*-*-*-*-*-*-*-* * * using unblocked code * * *-*-*-*-*-*-*-*-*-*-*-*-* * ACCPTD = 1 CALL ZGEQPC( JOB, M, N, K, A, LDA, C, LDC, MN-ACCPTD, $ ACCPTD, RCOND, LACPTD, JPVT, WORK( 1 ), $ WORK( MN+1 ), SVLUES, MXNM, WORK( 2*MN+1 ), $ LWORK-2*MN, RWORK ) RANK = ACCPTD+LACPTD * END IF ORCOND = SVLUES( IBEFOR )/SVLUES( IMAX ) * * Nullify the lower part of matrix A. * 30 CONTINUE DO 50 J = 1, MN DO 60 I = J+1, M A( I, J ) = CZERO 60 CONTINUE 50 CONTINUE * WORK( 1 ) = DBLE( WSIZE ) RETURN * * End of ZGEQPB * END SHAR_EOF fi # end of overwriting check if test -f 'zgeqpc.f' then echo shar: will not over-write existing file "'zgeqpc.f'" else cat << SHAR_EOF > 'zgeqpc.f' SUBROUTINE ZGEQPC( JOB, M, N, K, A, LDA, C, LDC, DSRD, OFFSET, $ IRCOND, LACPTD, JPVT, TAU, X, SVLUES, MXNM, $ WORK, LWORK, RWORK ) * * This code is part of a release of the package for computing * rank-revealing QR Factorizations written by: * ================================================================== * Christian H. Bischof and Gregorio Quintana-Orti * Math. and Comp. Sci. Div. Departamento de Informatica * Argonne National Lab. Universidad Jaime I * Argonne, IL 60439 Campus P. Roja, 12071 Castellon * USA Spain * bischof@mcs.anl.gov gquintan@inf.uji.es * ================================================================== * $Revision: 1.42 $ * $Date: 96/12/30 16:59:37 $ * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, DSRD, OFFSET, LACPTD, $ LWORK DOUBLE PRECISION IRCOND, MXNM * .. * .. Array Arguments .. INTEGER JPVT( * ) COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), $ WORK( * ), X( * ) DOUBLE PRECISION SVLUES( 4 ), RWORK( * ) * .. * * Purpose: * ======= * * ZGEQPC continues a partial QR factorization of A. If * A(1:OFFSET,1:OFFSET) has been reduced to upper triangular * form, then SGQPC applies the traditional column pivoting * strategy to identify DSRD more independent columns of A with * the restriction that the condition number of the leading * triangle of A should not be larger than 1/IRCOND. If * LACPTD ( <= DSRD) such columns are found, then the condition * number of * A(1:OFFSET+LACPTD,1:OFFSET+LACPTD) is less than 1/IRCOND. * If LACPTD < DSRD, then the QR factorization of A is completed, * otherwise only DSRD new steps were performed. * * Arguments: * ========= * * JOB (input) INTEGER * The job to do: * = 1: The transformations needed in the * triangularization are only applied to matrix A. * Thus, matrix C is not updated. * = 2: The same transformations needed in the * triangularization of matrix A are applied to * matrix C from the left. * That is, if Q'*A*P=R, then C := Q'*C. * In this case, matrix C is m-by-k. * = 3: The transpose of the transformations needed * in the triangularization of matrix A are applied * to matrix C from the right. * That is, if Q'*A*P=R, then C := C*Q. * In this case, matrix C is k-by-m. * In these three cases, the permutations are always saved * into vector JPVT. * * M (input) INTEGER * The number of rows of matrices A. M >= 0. * If JOB=2, M is the number of rows of matrix C. * If JOB=3, M is the number of columns of matrix C. * * N (input) INTEGER * The number of columns of matrix A. N >= 0. * * K (input) INTEGER * It defines the dimension of matrix C. K >= 0. * If JOB=2, K is the number of columns of matrix C. * If JOB=3, K is the number of rows of matrix C. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the m by n matrix A. * On exit, the upper triangle of the array contains the * min(m,n) by n upper trapezoidal matrix R; the lower triangle * array is filled with zeros. * * LDA (input) INTEGER * The leading dimension of array A. LDA >= max(1,M). * * C (input/output) COMPLEX*16 array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the transformations * applied to matrix A are also applied to matrix C. * * LDC (input) INTEGER * The leading dimension of array C. * If JOB=2, then LDC >= MAX(1,M). * If JOB=3, then LDC >= MAX(1,K). * * DSRD (input) INTEGER * The number of independent columns one would like to * extract. * * OFFSET (input) INTEGER * A(1:OFFSET,1:OFFSET) has already been factored. * OFFSET >= 0. * * IRCOND (input) DOUBLE PRECISION * 1/IRCOND is threshold for condition number. * * LACPTD (output) INTEGER * The number of additional columns that were identified * as independent. * * JPVT (input/output) INTEGER array, dimension (N) * If JPVT(I) = K, then the Ith column of the permuted * A was the Kth column of the original A. * * TAU (input/output) COMPLEX*16 array, dimension (MIN(M,N)) * Further details of the matrix Q (see A). * * X (input/output) COMPLEX*16 array, dimension (MIN(M,N)) * On entry: X(1:OFFSET) contains an approximate smallest * left singular vector of A(1:OFFSET,1:OFFSET) * On exit: X(1:OFFSET+LACPTD) contains an approximate * smallest left singular vector of * A(1:OFFSET+LACPTD,1:OFFSET+LACPTD). * * SVLUES (input/output) DOUBLE PRECISION array, dimension(4) * estimates of singular values. * On entry: SVLUES(1) = sigma_max(A(1:M,1:N)) * SVLUES(2) = sigma_min(A(1:OFFSET,1:OFFSET)) * On exit: SVLUES(1) = sigma_max(A(1:M,1:N)) * SVLUES(2) = sigma_r(B) * SVLUES(3) = sigma_(min(r+1,min(m,n)))(B) * SVLUES(4) = sigma_min(A) * where r = OFFSET+LACPTD and B = A(1:r,1:r) * * MXNM (input/output) FLOATING_DECLARE * On entry: norm of largest column in A(1:OFFSET,1:OFFSET) * On exit: norm of largest column in * A(1:J,1:J) where J = OFFSET+LACPTD * * WORK (workspace) FLOATING_DECLARE array, dimension (LWORK) * * LWORK (input) INTEGER * MAX( 1, N*NB ) if JOB=1, or * MAX( 1, MAX( N, K )*NB ) otherwise. * where NB is the maximum of blocksize used within xGEQRF and * blocksize used within xUNMQR. * * RWORK (workspace) DOUBLE PRECISION array, dimension ( 2*N ). * * Further Details * =============== * * The matrix Q is represented as a product of elementary reflectors * * Q = H(1) H(2) . . . H(n) * * Each H(i) has the form * * H = I - tau * v * v' * * where tau is a complex scalar, and v is a complex vector with * v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i). * * The matrix P is represented in jpvt as follows: If * jpvt(j) = i * then the jth column of P is the ith canonical unit vector. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE COMPLEX*16 CONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, $ CONE = ( 1.0D+0, 0.0D+0 ) ) * * Indices into the 'svlues' array. * INTEGER IMAX, IBEFOR, IAFTER, IMIN PARAMETER ( IMAX = 1, IBEFOR = 2, IAFTER = 3, IMIN = 4 ) * .. * .. Local Scalars .. INTEGER I, J, PVT, MN, ITEMP, INFO, LASTI DOUBLE PRECISION TEMP, TEMP2, SMIN, SMINPR, SMAX, SMAXPR COMPLEX*16 AII, SINE, COSINE * .. * .. External Subroutines .. EXTERNAL ZLARFG, ZLARF, ZSWAP, ZSCAL, $ ZLAIC1, ZGEQRF, ZUNMQR * .. * .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DZNRM2, DLASMX LOGICAL ZLAUC1 EXTERNAL IDAMAX, DZNRM2, DLASMX, ZLAUC1 * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, DCONJG * .. * .. Executable Statements .. * MN = MIN( M, N ) LACPTD = 0 IF( OFFSET.GT.0 ) THEN SMAX = SVLUES( IMAX ) SMIN = SVLUES( IBEFOR ) END IF * * Initialize partial column norms. The first n entries of * work store the exact column norms. * DO 10 I = OFFSET+1,N RWORK( I ) = DZNRM2( M-OFFSET, A( OFFSET+1, I ), 1 ) RWORK( N+I ) = RWORK( I ) 10 CONTINUE * * Compute factorization. * LASTI = MIN( MN, OFFSET+DSRD ) DO 20 I = OFFSET+1, LASTI * * Determine ith pivot column and swap if necessary. * PVT = ( I-1 )+IDAMAX( N-I+1, RWORK( I ), 1 ) IF( PVT.NE.I ) THEN CALL ZSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 ) ITEMP = JPVT( PVT ) JPVT( PVT ) = JPVT( I ) JPVT( I ) = ITEMP RWORK( PVT ) = RWORK( I ) RWORK( N+PVT ) = RWORK( N+I ) END IF * * Generate elementary reflector H(i). * IF( I.LT.M ) THEN CALL ZLARFG( M-I+1, A( I, I ), A( I+1, I ), 1, $ TAU( I ) ) ELSE CALL ZLARFG( 1, A( M, M ), A( M, M ), 1, TAU( M ) ) END IF * * Apply elementary reflector H(I) to the corresponding blocks * of matrices A and C. * AII = A( I, I ) A( I, I ) = CONE IF( I.LT.N ) THEN * * Apply H(I) to A(I:M,I+1:N) from the left. * CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1, $ DCONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK ) END IF IF( ( JOB.EQ.2 ).AND.( K.GT.0 ) ) THEN * * Apply H(I) to C(I:M,1:K) from the left. * CALL ZLARF( 'Left', M-I+1, K, A( I, I ), 1, $ DCONJG( TAU( I ) ), C( I, 1 ), LDC, WORK ) ELSE IF( ( JOB.EQ.3 ).AND.( K.GT.0 ) ) THEN * * Apply the transpose of H(I) to C(1:K,I:M) from the right. * CALL ZLARF( 'Right', K, M-I+1, A( I, I ), 1, $ TAU( I ), C( 1, I ), LDC, WORK ) END IF A( I, I ) = AII * * Update partial column norms. * IF( I.LT.LASTI ) THEN DO 30 J = I+1, N IF( RWORK( J ).NE.ZERO ) THEN TEMP = ONE-( ABS( A( I, J ) )/RWORK( J ) )**2 TEMP = MAX( TEMP, ZERO ) TEMP2 = ONE+0.05*TEMP*( RWORK( J )/RWORK( N+J ) )**2 IF( TEMP2.EQ.ONE ) THEN RWORK( J ) = DZNRM2( M-I, A( I+1, J ), 1 ) RWORK( N+J ) = RWORK( J ) ELSE RWORK( J ) = RWORK( J )*SQRT( TEMP ) END IF END IF 30 CONTINUE END IF * * Check new column for independence. * IF( I.EQ.1 ) THEN MXNM = ABS( A( 1, 1 ) ) SMIN = MXNM SMAX = MXNM X( 1 ) = CONE IF( MXNM.GT.ZERO ) THEN LACPTD = 1 ELSE SVLUES( IAFTER ) = SMIN GOTO 50 END IF ELSE SMAXPR = DLASMX( I )*MXNM IF( ZLAUC1( I, X, SMIN, A( 1, I ), A( I, I ), $ SMAXPR*IRCOND ) ) THEN * * Column accepted. * SMAX = SMAXPR LACPTD = LACPTD + 1 ELSE * * Column rejected. * GOTO 50 END IF END IF 20 CONTINUE 50 SVLUES( IMAX ) = SMAX SVLUES( IBEFOR ) = SMIN IF( LACPTD.EQ.DSRD ) THEN * * DSRD independent columns have been found. * SVLUES( IAFTER ) = SMIN SVLUES( IMIN ) = SMIN ELSE * * All remaining columns rejected. * I = OFFSET + LACPTD + 1 IF( I.LT.MN ) THEN * * Factor remaining columns. * CALL ZGEQRF( M-I, N-I, A( I+1, I+1 ), LDA, TAU( I+1 ), $ WORK, LWORK, INFO ) * * Apply the transformations computed in ZGEQRF to the * corresponding part of matrix C. * IF( ( JOB.EQ.2 ).AND.( K.GT.0 ) ) THEN * * Apply them to C(I+1:M,1:K) from the left. * CALL ZUNMQR( 'Left', 'Conjugate Transpose', $ M-I, K, MN-I, $ A( I+1, I+1 ), LDA, TAU( I+1 ), $ C( I+1, 1 ), LDC, WORK, LWORK, INFO ) ELSE IF( ( JOB.EQ.3 ).AND.( K.GT.0 ) ) THEN * * Apply the transpose of them to C(1:K,I+1:M) from the * right. * CALL ZUNMQR( 'Right', 'No Transpose', K, M-I, MN-I, $ A( I+1, I+1 ), LDA, TAU( I+1 ), $ C( 1, I+1 ), LDC, WORK, LWORK, INFO ) END IF END IF * * Use incremental condition estimation to get an estimate * of the smallest singular value. * DO 60 I = MAX( 2, OFFSET+LACPTD+1 ), MN CALL ZLAIC1( 2, I-1, X, SMIN, A( 1, I ), A( I, I ), $ SMINPR, SINE, COSINE ) CALL ZSCAL( I-1, SINE, X, 1 ) X( I ) = COSINE SMIN = SMINPR IF( I.EQ.OFFSET+LACPTD+1 ) THEN SVLUES( IAFTER ) = SMIN END IF 60 CONTINUE SVLUES( IMIN ) = SMIN END IF RETURN * * End of ZGEQPC * END SHAR_EOF fi # end of overwriting check if test -f 'zgeqpw.f' then echo shar: will not over-write existing file "'zgeqpw.f'" else cat << SHAR_EOF > 'zgeqpw.f' SUBROUTINE ZGEQPW( M, LWSIZE, NB, OFFSET, LACPTD, A, LDA, JPVT, $ IRCOND, X, SMIN, MXNM, TAU, WORK, RWORK ) * * This code is part of a release of the package for computing * rank-revealing QR Factorizations written by: * ================================================================== * Christian H. Bischof and Gregorio Quintana-Orti * Math. and Comp. Sci. Div. Departamento de Informatica * Argonne National Lab. Universidad Jaime I * Argonne, IL 60439 Campus P. Roja, 12071 Castellon * USA Spain * bischof@mcs.anl.gov gquintan@inf.uji.es * ================================================================== * $Revision: 1.42 $ * $Date: 96/12/30 16:59:38 $ * * .. Scalar Arguments .. INTEGER M, LWSIZE, NB, OFFSET, LACPTD, LDA DOUBLE PRECISION IRCOND, SMIN, MXNM * .. * .. Array Arguments .. INTEGER JPVT( * ) COMPLEX*16 A( LDA, * ), TAU( * ), X( * ), WORK( * ) DOUBLE PRECISION RWORK( * ) * * * Purpose * ======= * * ZGEQPW applies one block step of the Householder QR * factorization algorithm with restricted pivoting. It is called * by ZGEQPB to factorize a window of the matrix. * * Let A be the partial QR factorization of an M by (OFFSET+LWSIZE) * matrix C, i.e. we have computed an orthogonal matrix Q1 and a * permutation matrix P1 such that * C * P1 = Q1 * A * and A(:,1:OFFSET) is upper triangular. Let us denote A(:,1:OFFSET) * by B. Then in addition let * X be an approximate smallest left singular vector of B in the sense * that * sigma_min(B) ~ twonorm(B'*X) = SMIN * and * sigma_max(B) ~ ((offset)**(1./3.))*MXNM = SMAX * with * cond_no(B) ~ SMAX/SMIN <= 1/IRCOND * * Then ZGEQP2 tries to identify NB columns in * A(:,OFFSET+1:OFFSET+LWSIZE) such that * cond_no([B,D]) < 1/IRCOND * where D are the KB columns of A(:,OFFSET+1:OFFSET+LWSIZE) that were * considered independent with respect to the threshold 1/IRCOND. * * On exit, * C * P2 = Q2 * A * is again a partial QR factorization of C, but columns * OFFSET+1:OFFSET+LACPTD of A have been reduced via * a series of elementary reflectors to upper * trapezoidal form. Further * sigma_min(A(:,1:OFFSET+LACPTD)) * ~ twonorm(A(:,1:OFFSET+LACPTD)'*x) = SMIN * and * sigma_max(A(:,1:OFFSET+LACPTD)) ~ sqrt(OFFSET+LACPTD)*MXNM = SMAX * with * cond_no(A(:,1:OFFSET+LACPTD)) * ~ SMAX/SMIN <= 1/IRCOND. * * In the ideal case, LACPTD = NB, that is, * we found NB independent columns in the window consisting of * the first LWSIZE columns of A. * * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. * * LWSIZE (input) INTEGER * The size of the pivot window in A. * * NB (input) INTEGER * The number of independent columns one would like to identify. * This equals the desired blocksize in ZGEQPB. * * OFFSET (input) INTEGER * The number of rows and columns of A that need not be updated. * * LACPTD (output) INTEGER * The number of columns in A(:,OFFSET+LWSIZE) that were * accepted as linearly independent. * * A (input/output) COMPLEX*16 array, dimension (LDA,OFFSET+LWSIZE) * On entry, the upper triangle of A(:,1:OFFSET) contains the * partially completed triangular factor R; the elements below * the diagonal, with the array TAU, represent the matrix Q1 as * a product of elementary reflectors. * On exit, the upper triangle of A(:,OFFSET+LACPTD) contains * the partially completed upper triangular factor R; the * elements below the diagonal, with the array TAU, represent * the matrix Q2 as a product of elementary reflectors. * A(OFFSET:M,LACPTD+1:LWSIZE) has been updated by the product * of these elementary reflectors. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= M. * * JPVT (input/output) INTEGER array, dimension (OFFSET+LWSIZE) * On entry and exit, jpvt(i) = k if the i-th column * of A was the k-th column of C. * * IRCOND (input) DOUBLE PRECISION * 1/IRCOND is the threshold for the condition number. * * X (input/output) COMPLEX*16 array, dimension (OFFSET+NB) * On entry, X(1:OFFSET) is an approximate left nullvector of * the upper triangle of A(1:OFFSET,1:OFFSET). * On exit, X(1:OFFSET+LACPTD) is an approximate left * nullvector of the matrix in the upper triangle of * A(1:OFFSET+LACPTD,1:OFFSET+LACPTD). * * SMIN (input/output) DOUBLE PRECISION * On entry, SMIN is an estimate for the smallest singular * value of the upper triangle of A(1:OFFSET,1:OFFSET). * On exit, SMIN is an estimate for the smallest singular * value of the matrix in the upper triangle of * A(1:OFFSET+LACPTD,1:OFFSET+LACPTD). * * MXNM (input) FLOATING_DECLARE * The norm of the largest column in matrix A. * * TAU (output) COMPLEX*16 array, dimension (OFFSET+LWSIZE) * On exit, TAU(1:OFFSET+LACPTD) contains details of * the matrix Q2. * * WORK (workspace) COMPLEX*16 array, dimension (LWSIZE) * * RWORK (workspace) DOUBLE PRECISION array, dimension (2*LWSIZE) * * ================================================================ * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I, K, I1, PVTIDX, LASTK DOUBLE PRECISION TEMP, TEMP2, SMAX COMPLEX*16 GAMMA, AKK * .. * .. External Subroutines .. EXTERNAL DZNRM2, ZSCAL, ZSWAP, ZLARFG, $ ZLARF, IDAMAX, ZLAUC1, DLASMX INTEGER IDAMAX DOUBLE PRECISION DZNRM2, DLASMX LOGICAL ZLAUC1 * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT, DBLE, DCMPLX, DCONJG * .. * .. Executable Statements .. * * Initialize partial column norms (stored in the first LWSIZE * entries of WORK) and exact column norms (stored in the second * LWSIZE entries of WORK) for the first batch of columns. * DO 10 I = 1,LWSIZE RWORK( I ) = DZNRM2( M-OFFSET, A( OFFSET+1, OFFSET+I ), 1 ) RWORK( LWSIZE+I ) = RWORK( I ) 10 CONTINUE * * ************* * * Main loop * * ************* * LASTK = MIN( M, OFFSET+LWSIZE ) LACPTD = 0 1000 IF( LACPTD.EQ.NB ) GOTO 2000 * * Determine pivot candidate. * ========================= PVTIDX = OFFSET + LACPTD + $ IDAMAX( LWSIZE-LACPTD, RWORK( LACPTD+1 ), 1 ) K = OFFSET + LACPTD + 1 * * Exchange current column and pivot column. * IF( PVTIDX.NE.K ) THEN CALL ZSWAP( M, A( 1, PVTIDX ), 1, A( 1, K ), 1 ) I1 = JPVT( PVTIDX ) JPVT( PVTIDX ) = JPVT( K ) JPVT( K ) = I1 TEMP = RWORK( PVTIDX-OFFSET ) RWORK( PVTIDX-OFFSET ) = RWORK( K-OFFSET ) RWORK( K-OFFSET ) = TEMP TEMP = RWORK( PVTIDX-OFFSET+LWSIZE ) RWORK( PVTIDX-OFFSET+LWSIZE ) = RWORK( K+LWSIZE-OFFSET ) RWORK( K+LWSIZE-OFFSET ) = TEMP END IF * * Determine (offset+lacptd+1)st diagonal element * GAMMA of matrix A should elementary reflector be applied. * TEMP = DBLE( A( K, K ) ) IF( TEMP.EQ.ZERO ) THEN GAMMA = -RWORK( K-OFFSET ) ELSE GAMMA = -SIGN( RWORK( K-OFFSET ), TEMP ) END IF * * Update estimate for largest singular value. * SMAX = DLASMX( K )*MXNM * * Is candidate pivot column acceptable ? * ===================================== IF( ZLAUC1( K, X, SMIN, A( 1, K ), GAMMA, SMAX*IRCOND ) ) $ THEN * * Pivot candidate was accepted. * ============================ * LACPTD = LACPTD + 1 * * Generate Householder vector. * IF( K.LT.M ) THEN CALL ZLARFG( M-K+1, A( K, K ), A( K+1, K ), 1, $ TAU( K ) ) ELSE CALL ZLARFG( 1, A( M, K), A( M, K ), 1, TAU ( K ) ) END IF * * Apply Householder reflection to A(k:m,k+1:lwsize). * IF( LACPTD.LT.LWSIZE ) THEN AKK = A( K, K ) A( K, K ) = DCMPLX( ONE ) CALL ZLARF( 'Left', M-K+1, LWSIZE-LACPTD, $ A( K, K ), 1, DCONJG( TAU( K ) ), $ A( K, K+1 ), LDA, WORK ) A( K, K ) = AKK END IF * * Update partial column norms. * IF( K.LT.LASTK ) THEN DO 20 I = LACPTD+1,LWSIZE IF( RWORK( I ).NE.ZERO ) THEN TEMP = ONE- $ ( ABS( A( K, OFFSET+I ) )/RWORK( I ) )**2 TEMP = MAX( TEMP, ZERO ) TEMP2 = ONE+ 0.05*TEMP* $ ( RWORK( I )/RWORK( I+LWSIZE ) )**2 IF( TEMP2.EQ.ONE ) THEN RWORK( I ) = DZNRM2( M-K, $ A( K+1, OFFSET+I ), 1 ) RWORK( I+LWSIZE ) = RWORK( I ) ELSE RWORK( I ) = RWORK( I )*SQRT( TEMP ) END IF END IF 20 CONTINUE END IF ELSE * * Reject all remaining columns in pivot window. * ============================================ * GOTO 2000 END IF * * End while. * GOTO 1000 2000 CONTINUE RETURN * * End of ZGEQPW * END SHAR_EOF fi # end of overwriting check if test -f 'zgeqpx.f' then echo shar: will not over-write existing file "'zgeqpx.f'" else cat << SHAR_EOF > 'zgeqpx.f' SUBROUTINE ZGEQPX( JOB, M, N, K, A, LDA, C, LDC, JPVT, IRCOND, $ ORCOND, RANK, SVLUES, WORK, LWORK, RWORK, $ INFO ) * * This code is part of a release of the package for computing * rank-revealing QR Factorizations written by: * ================================================================== * Christian H. Bischof and Gregorio Quintana-Orti * Math. and Comp. Sci. Div. Departamento de Informatica * Argonne National Lab. Universidad Jaime I * Argonne, IL 60439 Campus P. Roja, 12071 Castellon * USA Spain * bischof@mcs.anl.gov gquintan@inf.uji.es * ================================================================== * $Revision: 1.42 $ * $Date: 96/12/30 16:59:38 $ * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, RANK, LWORK, INFO DOUBLE PRECISION IRCOND, ORCOND * .. * .. Array Arguments .. INTEGER JPVT( * ) COMPLEX*16 A( LDA, * ), C( LDC, * ), WORK( * ) DOUBLE PRECISION SVLUES( 4 ), RWORK( * ) * .. * * Purpose * ======= * * ZGEQPX computes a QR factorization * A*P = Q*[ R11 R12 ] * [ 0 R22 ] * of a real m by n matrix A. The permutation P is * chosen with the goal to reveal the rank of A by a * suitably dimensioned trailing submatrix R22 with norm(R22) * being small. * * Based on methods related to Chandrasekaran&Ipsen's algorithms. * * Arguments * ========= * * JOB (input) INTEGER * The job to do: * = 1: The transformations needed in the * triangularization are only applied to matrix A. * Thus, matrix C is not updated. * = 2: The same transformations needed in the * triangularization of matrix A are applied to * matrix C from the left. * That is, if Q'*A*P=R, then C := Q'*C. * In this case, matrix C is m-by-k. * = 3: The transpose of the transformations needed * in the triangularization of matrix A are applied * to matrix C from the right. * That is, if Q'*A*P=R, then C := C*Q. * In this case, matrix C is k-by-m. * In these three cases, the permutations are always saved * into vector JPVT. * * M (input) INTEGER * The number of rows of matrices A. M >= 0. * If JOB=2, M is the number of rows of matrix C. * If JOB=3, M is the number of columns of matrix C. * * N (input) INTEGER * The number of columns of matrix A. N >= 0. * * K (input) INTEGER * It defines the dimension of matrix C. K >= 0. * If JOB=2, K is the number of columns of matrix C. * If JOB=3, K is the number of rows of matrix C. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the m by n matrix A. * On exit, the upper triangle of the array contains the * min(m,n) by n upper trapezoidal matrix R; the lower triangle * array is filled with zeros. * * LDA (input) INTEGER * The leading dimension of array A. LDA >= MAX(1,M). * * C (input/output) COMPLEX*16 array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the transformations * applied to matrix A are also applied to matrix C. * * LDC (input) INTEGER * The leading dimension of array C. * If JOB=2, then LDC >= MAX(1,M). * If JOB=3, then LDC >= MAX(1,K). * * JPVT (output) INTEGER array, dimension (N) * JPVT(I) = J <==> Column J of A has been permuted into * position I in AP. * JPVT(1:RANK) contains the indices of the columns considered * linearly independent. * JPVT(RANK+1:N) contains the indices of the columns considered * linearly dependent from the previous ones. * * IRCOND (input) FLOATING_DECLARE * 1/IRCOND specifies an upper bound on the condition number * of R11. If IRCOND == 0, IRCOND = machine precision is chosen * as default. IRCOND must be >= 0. * * ORCOND (output) FLOATING_DECLARE * 1/ORCOND is an estimate for the condition number of R11. * * RANK (output) INTEGER * RANK is an estimate for the numerical rank of A with respect * to the threshold 1/IRCOND in the sense that * RANK = arg_max(cond_no(R(1:r,1:r))<1/IRCOND) * * SVLUES (output) DOUBLE PRECISION array, dimension (4) * On exit, SVLUES contains estimates of some of the * singular values of the triangular factor R. * SVLUES(1): largest singular value of R(1:RANK,1:RANK) * SVLUES(2): smallest singular value of R(1:RANK,1:RANK) * SVLUES(3): smallest singular value of R(1:RANK+1,1:RANK+1) * SVLUES(4): smallest singular value of R * If the triangular factorization is a rank-revealing one * (which will be the case if the leading columns were well- * conditioned), then SVLUES(1) will also be an estimate * for the largest singular value of A, SVLUES(2) and SVLUES(3) * will be estimates for the RANK-th and (RANK+1)-st singular * value of A, and SVLUES(4) wil be an estimate for the * smallest singular value of A. * By examining these values, one can confirm that the rank is * well defined with respect to the threshold chosen. * * WORK (workspace) COMPLEX*16 array, dimension (LWORK) * On exit: work(1) is the size of the storage array needed * for optimal performance * * LWORK (input) INTEGER * The dimension of array WORK. * If JOB=1: * The unblocked strategy requires that: * LWORK >= 2*MN+N. * The block algorithm requires that: * LWORK >= 2*MN+N*NB. * If JOB<>1: * The unblocked strategy requires that: * LWORK >= 2*MN+MAX(K,N). * The block algorithm requires that: * LWORK >= 2*MN+NB*NB+NB*MAX(K,N). * Where MN = min(M,N) and NB is the block size for this * environment. * In both cases, the minimum required workspace is the * one for the unblocked strategy. * * RWORK (workspace) DOUBLE PRECISION array, dimension ( 2*N ) * * INFO (output) INTEGER * = 0: Successful exit. * < 0: If INFO = -i, the i-th argument had an illegal value * > 0: Problems in the computation of the rank. * 1: Exceeded the allowed maximum number of steps. * 2: Rank not well defined. * In adition, vector SVLUES tell if rank is not well defined. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. External Subroutines .. EXTERNAL XERBLA, ZGEQPB, ZTRQPX * .. * .. Intrinsic Functions .. INTRINSIC MIN, MAX, DBLE * .. * .. Local Scalars .. DOUBLE PRECISION WSIZE INTEGER MN, WKMIN * .. * .. Executable Statements .. * MN = MIN( M, N ) IF( JOB.EQ.1 ) THEN WKMIN = 2*MN+N ELSE WKMIN = 2*MN+MAX(K,N) END IF * * Test input arguments * ==================== * INFO = 0 IF( ( JOB.LT.1 ).OR.( JOB.GT.3 ) ) THEN INFO = -1 ELSE IF( M.LT.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( K.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX(1,M) ) THEN INFO = -6 ELSE IF( ( ( JOB.EQ.1 ).AND.( LDC.LT.1 ) ).OR. $ ( ( JOB.EQ.2 ).AND.( LDC.LT.MAX( 1, M ) ) ).OR. $ ( ( JOB.EQ.3 ).AND.( LDC.LT.MAX( 1, K ) ) ) ) THEN INFO = -8 ELSE IF( IRCOND.LT.ZERO ) THEN INFO = -10 ELSE IF( LWORK.LT.MAX( 1, WKMIN ) ) THEN INFO = -15 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGEQPX',-INFO ) RETURN END IF * * Preprocessing * ============= * CALL ZGEQPB( JOB, M, N, K, A, LDA, C, LDC, JPVT, IRCOND, $ ORCOND, RANK, SVLUES, WORK, LWORK, RWORK, INFO ) WSIZE = DBLE( WORK( 1 ) ) * * Postprocessing * ============== * IF( RANK.GT.0 ) THEN CALL ZTRQPX( JOB, M, N, K, A, LDA, C, LDC, JPVT, IRCOND, $ ORCOND, RANK, SVLUES, WORK, RWORK, INFO ) END IF * WORK( 1 ) = WSIZE RETURN * * End of ZGEQPX * END SHAR_EOF fi # end of overwriting check if test -f 'zgeqpy.f' then echo shar: will not over-write existing file "'zgeqpy.f'" else cat << SHAR_EOF > 'zgeqpy.f' SUBROUTINE ZGEQPY( JOB, M, N, K, A, LDA, C, LDC, JPVT, IRCOND, $ ORCOND, RANK, SVLUES, WORK, LWORK, RWORK, $ INFO ) * * This code is part of a release of the package for computing * rank-revealing QR Factorizations written by: * ================================================================== * Christian H. Bischof and Gregorio Quintana-Orti * Math. and Comp. Sci. Div. Departamento de Informatica * Argonne National Lab. Universidad Jaime I * Argonne, IL 60439 Campus P. Roja, 12071 Castellon * USA Spain * bischof@mcs.anl.gov gquintan@inf.uji.es * ================================================================== * $Revision: 1.42 $ * $Date: 96/12/30 16:59:40 $ * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, RANK, LWORK, INFO DOUBLE PRECISION IRCOND, ORCOND * .. * .. Array Arguments .. INTEGER JPVT( * ) COMPLEX*16 A( LDA, * ), C( LDC, * ), WORK( * ) DOUBLE PRECISION SVLUES( 4 ), RWORK( * ) * .. * * Purpose * ======= * * ZGEQPY computes a QR factorization * A*P = Q*[ R11 R12 ] * [ 0 R22 ] * of a real m by n matrix A. The permutation P is * chosen with the goal to reveal the rank of A by a * suitably dimensioned trailing submatrix R22 with norm(R22) * being small. * * Based on Pan&Tang's algorithm number 3. * * Arguments * ========= * * JOB (input) INTEGER * The job to do: * = 1: The transformations needed in the * triangularization are only applied to matrix A. * Thus, matrix C is not updated. * = 2: The same transformations needed in the * triangularization of matrix A are applied to * matrix C from the left. * That is, if Q'*A*P=R, then C := Q'*C. * In this case, matrix C is m-by-k. * = 3: The transpose of the transformations needed * in the triangularization of matrix A are applied * to matrix C from the right. * That is, if Q'*A*P=R, then C := C*Q. * In this case, matrix C is k-by-m. * In these three cases, the permutations are always saved * into vector JPVT. * * M (input) INTEGER * The number of rows of matrices A. M >= 0. * If JOB=2, M is the number of rows of matrix C. * If JOB=3, M is the number of columns of matrix C. * * N (input) INTEGER * The number of columns of matrix A. N >= 0. * * K (input) INTEGER * It defines the dimension of matrix C. K >= 0. * If JOB=2, K is the number of columns of matrix C. * If JOB=3, K is the number of rows of matrix C. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the m by n matrix A. * On exit, the upper triangle of the array contains the * min(m,n) by n upper trapezoidal matrix R; the lower triangle * array is filled with zeros. * * LDA (input) INTEGER * The leading dimension of array A. LDA >= MAX(1,M). * * C (input/output) COMPLEX*16 array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the transformations * applied to matrix A are also applied to matrix C. * * LDC (input) INTEGER * The leading dimension of array C. * If JOB=2, then LDC >= MAX(1,M). * If JOB=3, then LDC >= MAX(1,K). * * JPVT (output) INTEGER array, dimension (N) * JPVT(I) = J <==> Column J of A has been permuted into * position I in AP. * JPVT(1:RANK) contains the indices of the columns considered * linearly independent. * JPVT(RANK+1:N) contains the indices of the columns considered * linearly dependent from the previous ones. * * IRCOND (input) FLOATING_DECLARE * 1/IRCOND specifies an upper bound on the condition number * of R11. If IRCOND == 0, IRCOND = machine precision is chosen * as default. IRCOND must be >= 0. * * ORCOND (output) FLOATING_DECLARE * 1/ORCOND is an estimate for the condition number of R11. * * RANK (output) INTEGER * RANK is an estimate for the numerical rank of A with respect * to the threshold 1/IRCOND in the sense that * RANK = arg_max(cond_no(R(1:r,1:r))<1/IRCOND) * * SVLUES (output) DOUBLE PRECISION array, dimension (4) * On exit, SVLUES contains estimates of some of the * singular values of the triangular factor R. * SVLUES(1): largest singular value of R(1:RANK,1:RANK) * SVLUES(2): smallest singular value of R(1:RANK,1:RANK) * SVLUES(3): smallest singular value of R(1:RANK+1,1:RANK+1) * SVLUES(4): smallest singular value of R * If the triangular factorization is a rank-revealing one * (which will be the case if the leading columns were well- * conditioned), then SVLUES(1) will also be an estimate * for the largest singular value of A, SVLUES(2) and SVLUES(3) * will be estimates for the RANK-th and (RANK+1)-st singular * value of A, and SVLUES(4) wil be an estimate for the * smallest singular value of A. * By examining these values, one can confirm that the rank is * well defined with respect to the threshold chosen. * * WORK (workspace) COMPLEX*16 array, dimension (LWORK) * On exit: work(1) is the size of the storage array needed * for optimal performance * * LWORK (input) INTEGER * The dimension of array WORK. * If JOB=1: * The unblocked strategy requires that: * LWORK >= 2*MN+N. * The block algorithm requires that: * LWORK >= 2*MN+N*NB. * If JOB<>1: * The unblocked strategy requires that: * LWORK >= 2*MN+MAX(K,N). * The block algorithm requires that: * LWORK >= 2*MN+NB*NB+NB*MAX(K,N). * Where MN = min(M,N) and NB is the block size for this * environment. * In both cases, the minimum required workspace is the * one for the unblocked strategy. * * RWORK (workspace) DOUBLE PRECISION array, dimension ( 2*N ) * * INFO (output) INTEGER * = 0: Successful exit. * < 0: If INFO = -i, the i-th argument had an illegal value * > 0: Problems in the computation of the rank. * 1: Exceeded the allowed maximum number of steps. * 2: Rank not well defined. * In adition, vector SVLUES tell if rank is not well defined. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. External Subroutines .. EXTERNAL XERBLA, ZGEQPB, ZTRQPY * .. * .. Intrinsic Functions .. INTRINSIC MIN, MAX, DBLE * .. * .. Local Scalars .. DOUBLE PRECISION WSIZE INTEGER MN, WKMIN * .. * .. Executable Statements .. * MN = MIN( M, N ) IF( JOB.EQ.1 ) THEN WKMIN = 2*MN+N ELSE WKMIN = 2*MN+MAX(K,N) END IF * * Test input arguments * ==================== * INFO = 0 IF( ( JOB.LT.1 ).OR.( JOB.GT.3 ) ) THEN INFO = -1 ELSE IF( M.LT.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( K.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX(1,M) ) THEN INFO = -6 ELSE IF( ( ( JOB.EQ.1 ).AND.( LDC.LT.1 ) ).OR. $ ( ( JOB.EQ.2 ).AND.( LDC.LT.MAX( 1, M ) ) ).OR. $ ( ( JOB.EQ.3 ).AND.( LDC.LT.MAX( 1, K ) ) ) ) THEN INFO = -8 ELSE IF( IRCOND.LT.ZERO ) THEN INFO = -10 ELSE IF( LWORK.LT.MAX( 1, WKMIN ) ) THEN INFO = -15 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGEQPY',-INFO ) RETURN END IF * * Preprocessing * ============= * CALL ZGEQPB( JOB, M, N, K, A, LDA, C, LDC, JPVT, IRCOND, $ ORCOND, RANK, SVLUES, WORK, LWORK, RWORK, INFO ) WSIZE = DBLE( WORK( 1 ) ) * * Postprocessing * ============== * IF( RANK.GT.0 ) THEN CALL ZTRQPY( JOB, M, N, K, A, LDA, C, LDC, JPVT, IRCOND, $ ORCOND, RANK, SVLUES, WORK, RWORK, INFO ) END IF * WORK( 1 ) = WSIZE RETURN * * End of ZGEQPY * END SHAR_EOF fi # end of overwriting check if test -f 'zlasmx.f' then echo shar: will not over-write existing file "'zlasmx.f'" else cat << SHAR_EOF > 'zlasmx.f' DOUBLE PRECISION FUNCTION DLASMX( I ) INTEGER I * DOUBLE PRECISION OTHIRD PARAMETER ( OTHIRD = 1.0D+0/3.0D+0 ) INTRINSIC DBLE DLASMX = DBLE( I )**OTHIRD RETURN END SHAR_EOF fi # end of overwriting check if test -f 'zlauc1.f' then echo shar: will not over-write existing file "'zlauc1.f'" else cat << SHAR_EOF > 'zlauc1.f' LOGICAL FUNCTION ZLAUC1( K, X, SMIN, W, GAMMA, THRESH ) * * This code is part of a release of the package for computing * rank-revealing QR Factorizations written by: * ================================================================== * Christian H. Bischof and Gregorio Quintana-Orti * Math. and Comp. Sci. Div. Departamento de Informatica * Argonne National Lab. Universidad Jaime I * Argonne, IL 60439 Campus P. Roja, 12071 Castellon * USA Spain * bischof@mcs.anl.gov gquintan@inf.uji.es * ================================================================== * $Revision: 1.42 $ * $Date: 96/12/30 16:59:41 $ * * .. Scalar Arguments .. INTEGER K DOUBLE PRECISION SMIN, THRESH COMPLEX*16 GAMMA * .. * .. Array Arguments .. COMPLEX*16 W( * ), X( * ) * .. * * Purpose * ======= * * PREC_LAUC1 applies incremental condition estimation to determine whether * the K-th column of A, stored in vector W, would be acceptable as a pivot * column with respect to the threshold THRESH. * * Arguments * ========= * * K (input) INTEGER * Length of vector X. * * X (input/output) COMPLEX*16 array, dimension ( K ) * On entry, X(1:K-1) contains an approximate smallest left singular * vector of the upper triangle of A(1:k-1,1:k-1). * On exit, if ZLAUC1 == .TRUE., X contains an approximate * smallest left singular vector of the upper triangle of A(1:k,1:k); * if ZLAUC1 == .FALSE., X is unchanged. * * SMIN (input/output) DOUBLE PRECISION * On entry, an estimate for the smallest singular value of the * upper triangle of A(1:k-1,1:k-1). * On exit, if ZLAUC1 == .TRUE., SMIN is an estimate of the * smallest singular value of the upper triangle of A(1:k,1:k); * if ZLAUC1 == .FALSE., SMIN is unchanged. * * W (input) FLOATING_DECLARE array, dimension ( K-1 ) * The K-th column of matrix A excluding the diagonal element. * * GAMMA (input) COMPLEX*16 * Diagonal entry in k-th column of A if column k were to * be accepted. * * THRESH (input) DOUBLE PRECISION * If the approximate smallest singular value for A(1:K,1:K) * is smaller than THRESH, the kth column is rejected. * * (ZLAUC1) (output) LOGICAL * If the k-th column of A is found acceptable, ZLAUC1 * returns .TRUE., otherwise it returns .FALSE. * * ===================================================================== * * .. Local Scalars .. DOUBLE PRECISION SMINPR COMPLEX*16 SINE, COSINE * .. * .. External Subroutines .. EXTERNAL ZLAIC1, ZSCAL * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. Executable Statements .. * * * Try to use diagonal element as condition estimator * IF( THRESH.GT.ABS( GAMMA ) ) THEN ZLAUC1 = .FALSE. RETURN END IF * * Use incremental condition estimation to determine an estimate * SMINPR and an approximate singular vector [SINE*X,COSINE]' * for A(K,K). * CALL ZLAIC1( 2, K-1, X, SMIN, W, GAMMA, SMINPR, $ SINE, COSINE ) IF( THRESH.GT.SMINPR ) THEN ZLAUC1 = .FALSE. ELSE CALL ZSCAL( K-1, SINE, X, 1 ) X( K ) = COSINE SMIN = SMINPR ZLAUC1 = .TRUE. END IF RETURN * * End of ZLAUC1 * END SHAR_EOF fi # end of overwriting check if test -f 'zmylap.f' then echo shar: will not over-write existing file "'zmylap.f'" else cat << SHAR_EOF > 'zmylap.f' ********************************************************************* SUBROUTINE ZGEQPF( M, N, A, LDA, JPVT, TAU, WORK, RWORK, INFO ) * * -- LAPACK auxiliary routine (version 1.0b) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. INTEGER JPVT( * ) DOUBLE PRECISION RWORK( * ) COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZGEQPF computes a QR factorization with column pivoting of a * complex m by n matrix A: A*P = Q*R * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0 * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the m by n matrix A. * On exit, the upper triangle of the array contains the * min(m,n) by n upper triangular matrix R; the elements * below the diagonal, together with the array TAU, * represent the orthogonal matrix Q as a product of * min(m,n) elementary reflectors. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * JPVT (input/output) INTEGER array, dimension (N) * on entry: If JPVT(I) <> 0, column I of A is permuted * to the front of AP (a leading column) * IF JPVT(I) == 0, column I of A is a free column. * on exit: If JPVT(I) = K, then the Ith column of AP * was the Kth column of A. * * TAU (output) COMPLEX*16 array, dimension (min(M,N)) * Stores further details of * the orthogonal matrix Q (see A). * * WORK (workspace) COMPLEX*16 array, dimension (N) * * RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * Further Details * =============== * * The matrix Q is represented as a product of elementary reflectors * * Q = H(1) H(2) . . . H(n) * * Each H(i) has the form * * H = I - tau * v * v' * * where tau is a complex scalar, and v is a complex vector with * v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i). * * The matrix P is represented in jpvt as follows: If * jpvt(j) = i * then the jth column of P is the ith canonical unit vector. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I, ITEMP, J, MA, MN, PVT DOUBLE PRECISION TEMP, TEMP2 COMPLEX*16 AII * .. * .. External Subroutines .. EXTERNAL XERBLA, ZGEQR2, ZLARF, ZLARFG, ZSWAP, ZUNM2R * .. * .. Intrinsic Functions .. INTRINSIC ABS, DCMPLX, DCONJG, MAX, MIN, SQRT * .. * .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DZNRM2 EXTERNAL IDAMAX, DZNRM2 * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGEQPF', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * MN = MIN( M, N ) * * Move initial columns up front * ITEMP = 1 DO 10 I = 1, N IF( JPVT( I ).NE.0 ) THEN IF( I.NE.ITEMP ) THEN CALL ZSWAP( M, A( 1, I ), 1, A( 1, ITEMP ), 1 ) JPVT( I ) = JPVT( ITEMP ) JPVT( ITEMP ) = I ELSE JPVT( I ) = I END IF ITEMP = ITEMP + 1 ELSE JPVT( I ) = I END IF 10 CONTINUE ITEMP = ITEMP - 1 * * Compute the QR factorization and update remaining columns * IF( ITEMP.GT.0 ) THEN MA = MIN( ITEMP, M ) CALL ZGEQR2( M, MA, A, LDA, TAU, WORK, INFO ) IF( MA.LT.N ) THEN CALL ZUNM2R( 'Left', 'Conjugate transpose', M, N-MA, MA, A, $ LDA, TAU, A( 1, MA+1 ), LDA, WORK, INFO ) END IF END IF * IF( ITEMP.LT.MN ) THEN * * Initialize partial column norms. The first n entries of * work store the exact column norms. * DO 20 I = ITEMP + 1, N RWORK( I ) = DZNRM2( M-ITEMP, A( ITEMP+1, I ), 1 ) RWORK( N+I ) = RWORK( I ) 20 CONTINUE * * Compute factorization * DO 40 I = ITEMP + 1, MN * * Determine ith pivot column and swap if necessary * PVT = ( I-1 ) + IDAMAX( N-I+1, RWORK( I ), 1 ) * IF( PVT.NE.I ) THEN CALL ZSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 ) ITEMP = JPVT( PVT ) JPVT( PVT ) = JPVT( I ) JPVT( I ) = ITEMP RWORK( PVT ) = RWORK( I ) RWORK( N+PVT ) = RWORK( N+I ) END IF * * Generate elementary reflector H(i) * AII = A( I, I ) CALL ZLARFG( M-I+1, AII, A( MIN( I+1, M ), I ), 1, $ TAU( I ) ) A( I, I ) = AII * IF( I.LT.N ) THEN * * Apply H(i) to A(i:m,i+1:n) from the left * AII = A( I, I ) A( I, I ) = DCMPLX( ONE ) CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1, $ DCONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK ) A( I, I ) = AII END IF * * Update partial column norms * DO 30 J = I + 1, N IF( RWORK( J ).NE.ZERO ) THEN TEMP = ONE - ( ABS( A( I, J ) ) / RWORK( J ) )**2 TEMP = MAX( TEMP, ZERO ) TEMP2 = ONE + 0.05D0*TEMP* $ ( RWORK( J ) / RWORK( N+J ) )**2 IF( TEMP2.EQ.ONE ) THEN IF( M-I.GT.0 ) THEN RWORK( J ) = DZNRM2( M-I, A( I+1, J ), 1 ) RWORK( N+J ) = RWORK( J ) ELSE RWORK( J ) = ZERO RWORK( N+J ) = ZERO END IF ELSE RWORK( J ) = RWORK( J )*SQRT( TEMP ) END IF END IF 30 CONTINUE * 40 CONTINUE END IF RETURN * * End of ZGEQPF * END ********************************************************************* SUBROUTINE ZGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK routine (version 1.0b) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), TAU( * ), WORK( LWORK ) * .. * * Purpose * ======= * * ZGEQRF computes a QR factorization of a complex m by n matrix A: * A = Q * R. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the m by n matrix A. * On exit, the elements on and above the diagonal of the array * contain the min(m,n) by n upper trapezoidal matrix R (R is * upper triangular if m >= n); the elements below the diagonal, * with the array TAU, represent the unitary matrix Q as a * product of elementary reflectors (see Further Details). * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * TAU (output) COMPLEX*16 array, dimension (min(M,N)) * The scalar factors of the elementary reflectors (see Further * Details). * * WORK (workspace) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the minimum value of * LWORK required to use the optimal blocksize. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= max(1,N). * For optimum performance LWORK should be at least N*NB, * where NB is the optimal blocksize. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * Further Details * =============== * * The matrix Q is represented as a product of elementary reflectors * * Q = H(1) H(2) . . . H(k), where k = min(m,n). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a complex scalar, and v is a complex vector with * v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), * and tau in TAU(i). * * ===================================================================== * * .. Local Scalars .. INTEGER I, IB, IINFO, IWS, K, LDWORK, NB, NBMIN, NX * .. * .. External Subroutines .. EXTERNAL XERBLA, ZGEQR2, ZLARFB, ZLARFT * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 ELSE IF( LWORK.LT.MAX( 1, N ) ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGEQRF', -INFO ) RETURN END IF * * Quick return if possible * K = MIN( M, N ) IF( K.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * * Determine the block size. * NB = ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 ) NBMIN = 2 NX = 0 IWS = N IF( NB.GT.1 .AND. NB.LT.K ) THEN * * Determine when to cross over from blocked to unblocked code. * NX = MAX( 0, ILAENV( 3, 'ZGEQRF', ' ', M, N, -1, -1 ) ) IF( NX.LT.K ) THEN * * Determine if workspace is large enough for blocked code. * LDWORK = N IWS = LDWORK*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: reduce NB and * determine the minimum value of NB. * NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'ZGEQRF', ' ', M, N, -1, $ -1 ) ) END IF END IF END IF * IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN * * Use blocked code initially * DO 10 I = 1, K - NX, NB IB = MIN( K-I+1, NB ) * * Compute the QR factorization of the current block * A(i:m,i:i+ib-1) * CALL ZGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), WORK, $ IINFO ) IF( I+IB.LE.N ) THEN * * Form the triangular factor of the block reflector * H = H(i) H(i+1) . . . H(i+ib-1) * CALL ZLARFT( 'Forward', 'Columnwise', M-I+1, IB, $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) * * Apply H' to A(i:m,i+ib:n) from the left * CALL ZLARFB( 'Left', 'Conjugate transpose', 'Forward', $ 'Columnwise', M-I+1, N-I-IB+1, IB, $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), $ LDA, WORK( IB+1 ), LDWORK ) END IF 10 CONTINUE ELSE I = 1 END IF * * Use unblocked code to factor the last or only block. * IF( I.LE.K ) $ CALL ZGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, $ IINFO ) * WORK( 1 ) = IWS RETURN * * End of ZGEQRF * END ********************************************************************* SUBROUTINE ZGEQR2( M, N, A, LDA, TAU, WORK, INFO ) * * -- LAPACK routine (version 1.0b) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZGEQR2 computes a QR factorization of a complex m by n matrix A: * A = Q * R. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the m by n matrix A. * On exit, the elements on and above the diagonal of the array * contain the min(m,n) by n upper trapezoidal matrix R (R is * upper triangular if m >= n); the elements below the diagonal, * with the array TAU, represent the unitary matrix Q as a * product of elementary reflectors (see Further Details). * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * TAU (output) COMPLEX*16 array, dimension (min(M,N)) * The scalar factors of the elementary reflectors (see Further * Details). * * WORK (workspace) COMPLEX*16 array, dimension (N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * Further Details * =============== * * The matrix Q is represented as a product of elementary reflectors * * Q = H(1) H(2) . . . H(k), where k = min(m,n). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a complex scalar, and v is a complex vector with * v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), * and tau in TAU(i). * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I, K COMPLEX*16 ALPHA * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARF, ZLARFG * .. * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGEQR2', -INFO ) RETURN END IF * K = MIN( M, N ) * DO 10 I = 1, K * * Generate elementary reflector H(i) to annihilate A(i+1:m,i) * CALL ZLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, $ TAU( I ) ) IF( I.LT.N ) THEN * * Apply H(i)' to A(i:m,i+1:n) from the left * ALPHA = A( I, I ) A( I, I ) = ONE CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1, $ DCONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK ) A( I, I ) = ALPHA END IF 10 CONTINUE RETURN * * End of ZGEQR2 * END ********************************************************************* SHAR_EOF fi # end of overwriting check if test -f 'ztrqpx.f' then echo shar: will not over-write existing file "'ztrqpx.f'" else cat << SHAR_EOF > 'ztrqpx.f' SUBROUTINE ZTRQPX( JOB, M, N, K, A, LDA, C, LDC, JPVT, IRCOND, $ ORCOND, RANK, SVLUES, WORK, RWORK, INFO ) * * This code is part of a release of the package for computing * rank-revealing QR Factorizations written by: * ================================================================== * Christian H. Bischof and Gregorio Quintana-Orti * Math. and Comp. Sci. Div. Departamento de Informatica * Argonne National Lab. Universidad Jaime I * Argonne, IL 60439 Campus P. Roja, 12071 Castellon * USA Spain * bischof@mcs.anl.gov gquintan@inf.uji.es * ================================================================== * $Revision: 1.42 $ * $Date: 96/12/30 16:59:42 $ * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, RANK, INFO DOUBLE PRECISION IRCOND, ORCOND * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), C( LDC, * ), WORK( * ) DOUBLE PRECISION SVLUES( 4 ), RWORK( * ) INTEGER JPVT( * ) * .. * * Purpose * ======= * * ZTRQPX detects the right rank for upper triangular matrix A. * The algorithm used here is related to Chandrasekaran&Ipsen * algorithm Hybrid-III. * This algorithm is applied to matrix A until the right rank is * obtained. If the input ordering of matrix A is not accepted, the * matrix will be permuted and retriangularized until the rank is * revealed. * * Arguments * ========= * * JOB (input) INTEGER * The job to do: * = 1: The transformations needed in the * triangularization are only applied to matrix A. * Thus, matrix C is not updated. * = 2: The same transformations needed in the * triangularization of matrix A are applied to * matrix C from the left. * That is, if Q'*A*P=R, then C := Q'*C. * In this case, matrix C is m-by-k. * = 3: The transpose of the transformations needed * in the triangularization of matrix A are applied * to matrix C from the right. * That is, if Q'*A*P=R, then C := C*Q. * In this case, matrix C is k-by-m. * In these three cases, the permutations are always stored * in vector JPVT. * * M (input) INTEGER * The number of rows of matrices A. M >= 0. * If JOB=2, M is the number of rows of matrix C. * If JOB=3, M is the number of columns of matrix C. * * N (input) INTEGER * The number of columns of matrix A. N >= 0. * * K (input) INTEGER * It defines the dimension of matrix C. K >= 0. * If JOB=2, K is the number of columns of matrix C. * If JOB=3, K is the number of rows of matrix C. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the m by n matrix A. * On exit, the upper triangle of the array contains the * min(m,n) by n upper trapezoidal matrix R; the lower triangle * array is filled with zeros. * * LDA (input) INTEGER * The leading dimension of array A. LDA >= max(1,M). * * C (input/output) COMPLEX*16 array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the transformations * applied to matrix A are also applied to matrix C. * * LDC (input) INTEGER * The leading dimension of array C. * If JOB=2, then LDC >= MAX(1,M). * If JOB=3, then LDC >= MAX(1,K). * * JPVT (input/output) INTEGER array, dimension ( N ) * If JPVT(I) = K, then the Ith column of the permuted * A was the Kth column of the original A (just before * the preprocessing). If a permutation occurs, JPVT will * be updated correctly. * JPVT(1:RANK) contains the indices of the columns considered * linearly independent. * JPVT(RANK+1:N) contains the indices of the columns considered * linearly dependent from the previous ones. * * IRCOND (input) FLOATING_DECLARE * 1/IRCOND specifies an upper bound on the condition number * of R11. If IRCOND == 0, IRCOND = machine precision is chosen * as default. IRCOND must be >= 0. * * ORCOND (output) FLOATING_DECLARE * 1/ORCOND is an estimate for the condition number of R11. * * RANK (output) INTEGER * An estimate of the rank offered by this algorithm. * 0 <= RANK <= MIN(M,N). * * SVLUES (output) DOUBLE PRECISION array, dimension (4) * On exit, SVLUES contains estimates of some of the singular * values of the triangular factor R. * SVLUES(1): largest singular value of R(1:RANK,1:RANK) * SVLUES(2): smallest singular value of R(1:RANK,1:RANK) * SVLUES(3): smallest singular value of R(1:RANK+1,1:RANK+1) * SVLUES(4): smallest singular value of R * If the triangular factorization is a rank-revealing one * (which will be the case if the leading columns were well- * conditioned), then SVLUES(1) will also be an estimate * for the largest singular value of A, SVLUES(2) and SVLUES(3) * will be estimates for the RANK-th and (RANK+1)-st singular * value of A, and SVLUES(4) will be an estimate for the * smallest singular value of A. * By examining these values, one can confirm that the rank is * well defined with respect to the threshold chosen. * * WORK (workspace) COMPLEX*16 array, dimension ( 2*MIN(M,N) ) * * RWORK (workspace) DOUBLE PRECISION array, dimension ( MIN(M,N)+N ) * * INFO (output) INTEGER * = 0: Successful exit. * < 0: If INFO = -i, the i-th argument had an illegal value * > 0: Problems in the computation of the rank. * 1: Exceeded the allowed maximum number of steps. * 2: Rank not well defined. * In adition, vector SVLUES tell if rank is not well defined. * When INFO.NE.0, the contents of ORCOND may be not the right * one. * * * =================================================================== * * .. Parameters .. INTEGER INB DOUBLE PRECISION ZERO PARAMETER ( INB = 1, ZERO = 0.0D+0 ) * * Indices into the 'svlues' array. * INTEGER IMAX, IBEFOR, IAFTER, IMIN PARAMETER ( IMAX = 1, IBEFOR = 2, IAFTER = 3, IMIN = 4 ) * .. * .. * .. Common Block .. INTEGER NB COMMON /BSPRQR/ NB * .. * .. Local Scalars .. DOUBLE PRECISION RCNR, RCNRP1, RCOND LOGICAL GOLEFT, RNKDTD INTEGER MN, OINFO * .. * .. External Functions .. INTEGER ILAENV DOUBLE PRECISION DLAMCH EXTERNAL ILAENV, DLAMCH * .. * .. External Subroutines .. EXTERNAL XERBLA, ZTRQXC * .. * .. Intrinsic Functions .. INTRINSIC MIN, MAX * .. * .. Executable Statements .. * MN = MIN( M, N ) NB = ILAENV( INB, 'ZGEQRF', ' ', M, N, 0, 0 ) * * Test input arguments * ==================== * INFO = 0 IF( ( JOB.LT.1 ).OR.( JOB.GT.3 ) ) THEN INFO = -1 ELSE IF( M.LT.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( K.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX(1,M) ) THEN INFO = -6 ELSE IF( ( ( JOB.EQ.1 ).AND.( LDC.LT.1 ) ).OR. $ ( ( JOB.EQ.2 ).AND.( LDC.LT.MAX( 1, M ) ) ).OR. $ ( ( JOB.EQ.3 ).AND.( LDC.LT.MAX( 1, K ) ) ) ) THEN INFO = -8 ELSE IF( IRCOND.LT.ZERO ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZTRQPX', -INFO ) RETURN END IF * * Quick return if possible. * IF( MN.EQ.0 ) THEN RANK = 0 ORCOND = ZERO SVLUES( IMAX ) = ZERO SVLUES( IBEFOR ) = ZERO SVLUES( IAFTER ) = ZERO SVLUES( IMIN ) = ZERO RETURN END IF * * Check whether Threshold for condition number was supplied. * If not, choose machine precision as default for RCOND. * IF( IRCOND.GT.ZERO ) THEN RCOND = IRCOND ELSE RCOND = DLAMCH( 'Epsilon' ) END IF * * Compute the initial estimate for the rank. * CALL ZTRRNK( MN, A, LDA, RCOND, RANK, WORK, INFO ) * * ************************ * * First call to xTRQXC * * ************************ * * Get tighter bounds for the value RANK. * CALL ZTRQXC( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ RANK, SVLUES, RCNR, RCNRP1, WORK, RWORK, INFO ) OINFO = 0 IF( INFO.NE.0 ) $ OINFO = INFO * * Check if the numerical rank is larger, equal or smaller than * the contents of RANK. * IF( ( ( RCNR.GE.RCOND ).AND.( RANK.EQ.MN ) ).OR. $ ( ( RCNR.GE.RCOND ).AND.( RCNRP1.LT.RCOND ) ) ) THEN RNKDTD = .TRUE. ELSE IF( ( RCNR.GE.RCOND ).AND.( RCNRP1.GE.RCOND ) ) THEN RNKDTD = .FALSE. GOLEFT = .FALSE. RANK = RANK + 1 ELSE IF( ( RCNR.LT.RCOND ).AND.( RCNRP1.LT.RCOND ) ) THEN IF( RANK.EQ.1 ) THEN RNKDTD = .TRUE. IF( ABS( A( 1, 1 ) ).EQ.ZERO ) THEN RANK = 0 ORCOND = ZERO SVLUES( IMAX ) = ZERO SVLUES( IBEFOR ) = ZERO SVLUES( IAFTER ) = ZERO SVLUES( IMIN ) = ZERO ELSE RANK = 1 END IF ELSE RNKDTD = .FALSE. GOLEFT = .TRUE. RANK = RANK - 1 END IF ELSE RNKDTD = .TRUE. INFO = 2 END IF * * ***************** * * Start of Loop * * ***************** * * Loop for the detection of the actual rank. The variable RANK is * updated until the rank is found. To avoid infinite loops, the * variable RANK either increases or decreases. * 10 CONTINUE IF( .NOT. RNKDTD ) THEN * * Call to xTRQXC to get tighter bounds for the value RANK. * CALL ZTRQXC( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ RANK, SVLUES, RCNR, RCNRP1, WORK, RWORK, INFO ) IF( INFO.NE.0 ) $ OINFO = INFO * * Check if the numerical rank is larger, equal or smaller than * the contents of RANK. * IF( ( ( RCNR.GE.RCOND ).AND.( RANK.EQ.MN ) ).OR. $ ( ( RCNR.GE.RCOND ).AND.( RCNRP1.LT.RCOND ) ) ) THEN RNKDTD = .TRUE. ELSE IF( ( RCNR.GE.RCOND ).AND.( RCNRP1.GE.RCOND ) ) THEN IF( .NOT. GOLEFT ) THEN RANK = RANK + 1 ELSE RNKDTD = .TRUE. INFO = 2 END IF ELSE IF( ( RCNR.LT.RCOND ).AND.( RCNRP1.LT.RCOND ) ) THEN IF( RANK.EQ.1 ) THEN RNKDTD = .TRUE. IF( ABS( A( 1, 1 ) ).EQ.ZERO ) THEN RANK = 0 ORCOND = ZERO SVLUES( IMAX ) = ZERO SVLUES( IBEFOR ) = ZERO SVLUES( IAFTER ) = ZERO SVLUES( IMIN ) = ZERO ELSE RANK = 1 END IF ELSE GOLEFT = .TRUE. RANK = RANK - 1 END IF ELSE RNKDTD = .TRUE. INFO = 2 END IF * * Jump to the beginning of the loop. * GOTO 10 END IF * * *************** * * end of loop * * *************** * * Give back the obtained value of RCOND and check the value of INFO. * ORCOND = RCNR IF( OINFO.NE.0 ) $ INFO = OINFO * RETURN * * End of ZTRQPX * END SHAR_EOF fi # end of overwriting check if test -f 'ztrqpy.f' then echo shar: will not over-write existing file "'ztrqpy.f'" else cat << SHAR_EOF > 'ztrqpy.f' SUBROUTINE ZTRQPY( JOB, M, N, K, A, LDA, C, LDC, JPVT, IRCOND, $ ORCOND, RANK, SVLUES, WORK, RWORK, INFO ) * * This code is part of a release of the package for computing * rank-revealing QR Factorizations written by: * ================================================================== * Christian H. Bischof and Gregorio Quintana-Orti * Math. and Comp. Sci. Div. Departamento de Informatica * Argonne National Lab. Universidad Jaime I * Argonne, IL 60439 Campus P. Roja, 12071 Castellon * USA Spain * bischof@mcs.anl.gov gquintan@inf.uji.es * ================================================================== * $Revision: 1.42 $ * $Date: 96/12/30 16:59:43 $ * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, RANK, INFO DOUBLE PRECISION IRCOND, ORCOND * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), C( LDC, * ), WORK( * ) DOUBLE PRECISION SVLUES( 4 ), RWORK( * ) INTEGER JPVT( * ) * .. * * Purpose * ======= * * ZTRQPY detects the right rank for upper triangular matrix A. * The algorithm used here is an version of Pan and Tang's RRQR * algorithm number 3. * This algorithm is applied to matrix A until the right rank is * obtained. If the input ordering of matrix A is not accepted, the * matrix will be permuted and retriangularized until the rank is * revealed. * * Arguments * ========= * * JOB (input) INTEGER * The job to do: * = 1: The transformations needed in the * triangularization are only applied to matrix A. * Thus, matrix C is not updated. * = 2: The same transformations needed in the * triangularization of matrix A are applied to * matrix C from the left. * That is, if Q'*A*P=R, then C := Q'*C. * In this case, matrix C is m-by-k. * = 3: The transpose of the transformations needed * in the triangularization of matrix A are applied * to matrix C from the right. * That is, if Q'*A*P=R, then C := C*Q. * In this case, matrix C is k-by-m. * In these three cases, the permutations are always stored * in vector JPVT. * * M (input) INTEGER * The number of rows of matrices A. M >= 0. * If JOB=2, M is the number of rows of matrix C. * If JOB=3, M is the number of columns of matrix C. * * N (input) INTEGER * The number of columns of matrix A. N >= 0. * * K (input) INTEGER * It defines the dimension of matrix C. K >= 0. * If JOB=2, K is the number of columns of matrix C. * If JOB=3, K is the number of rows of matrix C. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the m by n matrix A. * On exit, the upper triangle of the array contains the * min(m,n) by n upper trapezoidal matrix R; the lower triangle * array is filled with zeros. * * LDA (input) INTEGER * The leading dimension of array A. LDA >= max(1,M). * * C (input/output) COMPLEX*16 array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the transformations * applied to matrix A are also applied to matrix C. * * LDC (input) INTEGER * The leading dimension of array C. * If JOB=2, then LDC >= MAX(1,M). * If JOB=3, then LDC >= MAX(1,K). * * JPVT (input/output) INTEGER array, dimension ( N ) * If JPVT(I) = K, then the Ith column of the permuted * A was the Kth column of the original A (just before * the preprocessing). If a permutation occurs, JPVT will * be updated correctly. * JPVT(1:RANK) contains the indices of the columns considered * linearly independent. * JPVT(RANK+1:N) contains the indices of the columns considered * linearly dependent from the previous ones. * * IRCOND (input) FLOATING_DECLARE * 1/IRCOND specifies an upper bound on the condition number * of R11. If IRCOND == 0, IRCOND = machine precision is chosen * as default. IRCOND must be >= 0. * * ORCOND (output) FLOATING_DECLARE * 1/ORCOND is an estimate for the condition number of R11. * * RANK (output) INTEGER * An estimate of the rank offered by this algorithm. * 0 <= RANK <= MIN(M,N). * * SVLUES (output) DOUBLE PRECISION array, dimension (4) * On exit, SVLUES contains estimates of some of the singular * values of the triangular factor R. * SVLUES(1): largest singular value of R(1:RANK,1:RANK) * SVLUES(2): smallest singular value of R(1:RANK,1:RANK) * SVLUES(3): smallest singular value of R(1:RANK+1,1:RANK+1) * SVLUES(4): smallest singular value of R * If the triangular factorization is a rank-revealing one * (which will be the case if the leading columns were well- * conditioned), then SVLUES(1) will also be an estimate * for the largest singular value of A, SVLUES(2) and SVLUES(3) * will be estimates for the RANK-th and (RANK+1)-st singular * value of A, and SVLUES(4) will be an estimate for the * smallest singular value of A. * By examining these values, one can confirm that the rank is * well defined with respect to the threshold chosen. * * WORK (workspace) COMPLEX*16 array, dimension ( MIN(M,N) ) * * RWORK (workspace) DOUBLE PRECISION array, dimension ( MIN(M,N)+N ) * * INFO (output) INTEGER * = 0: Successful exit. * < 0: If INFO = -i, the i-th argument had an illegal value * > 0: Problems in the computation of the rank. * 1: Exceeded the allowed maximum number of steps. * 2: Rank not well defined. * In adition, vector SVLUES tell if rank is not well defined. * When INFO.NE.0, the contents of ORCOND may be not the right * one. * * * =================================================================== * * .. Parameters .. INTEGER INB DOUBLE PRECISION ZERO PARAMETER ( INB = 1, ZERO = 0.0D+0 ) * * Indices into the 'svlues' array. * INTEGER IMAX, IBEFOR, IAFTER, IMIN PARAMETER ( IMAX = 1, IBEFOR = 2, IAFTER = 3, IMIN = 4 ) * .. * .. * .. Common Block .. INTEGER NB COMMON /BSPRQR/ NB * .. * .. Local Scalars .. DOUBLE PRECISION RCNR, RCNRP1, RCOND LOGICAL GOLEFT, RNKDTD INTEGER MN, OINFO * .. * .. External Functions .. INTEGER ILAENV DOUBLE PRECISION DLAMCH EXTERNAL ILAENV, DLAMCH * .. * .. External Subroutines .. EXTERNAL XERBLA, ZTRQYC, ZTRRNK * .. * .. Intrinsic Functions .. INTRINSIC MIN, MAX * .. * .. Executable Statements .. * MN = MIN( M, N ) NB = ILAENV( INB, 'ZGEQRF', ' ', M, N, 0, 0 ) * * Test input arguments * ==================== * INFO = 0 IF( ( JOB.LT.1 ).OR.( JOB.GT.3 ) ) THEN INFO = -1 ELSE IF( M.LT.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( K.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX(1,M) ) THEN INFO = -6 ELSE IF( ( ( JOB.EQ.1 ).AND.( LDC.LT.1 ) ).OR. $ ( ( JOB.EQ.2 ).AND.( LDC.LT.MAX( 1, M ) ) ).OR. $ ( ( JOB.EQ.3 ).AND.( LDC.LT.MAX( 1, K ) ) ) ) THEN INFO = -8 ELSE IF( IRCOND.LT.ZERO ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZTRQPY', -INFO ) RETURN END IF * * Quick return if possible. * IF( MN.EQ.0 ) THEN RANK = 0 ORCOND = ZERO SVLUES( IMAX ) = ZERO SVLUES( IBEFOR ) = ZERO SVLUES( IAFTER ) = ZERO SVLUES( IMIN ) = ZERO RETURN END IF * * Check whether Threshold for condition number was supplied. * If not, choose machine precision as default for RCOND. * IF( IRCOND.GT.ZERO ) THEN RCOND = IRCOND ELSE RCOND = DLAMCH( 'Epsilon' ) END IF * * Compute the initial estimate for the rank. * CALL ZTRRNK( MN, A, LDA, RCOND, RANK, WORK, INFO ) * * ************************ * * First call to xTRQYC * * ************************ * * Get tighter bounds for the value RANK. * CALL ZTRQYC( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ RANK, SVLUES, RCNR, RCNRP1, WORK, RWORK, INFO ) OINFO = 0 IF( INFO.NE.0 ) $ OINFO = INFO * * Check if the numerical rank is larger, equal or smaller than * the contents of RANK. * IF( ( ( RCNR.GE.RCOND ).AND.( RANK.EQ.MN ) ).OR. $ ( ( RCNR.GE.RCOND ).AND.( RCNRP1.LT.RCOND ) ) ) THEN RNKDTD = .TRUE. ELSE IF( ( RCNR.GE.RCOND ).AND.( RCNRP1.GE.RCOND ) ) THEN RNKDTD = .FALSE. GOLEFT = .FALSE. RANK = RANK + 1 ELSE IF( ( RCNR.LT.RCOND ).AND.( RCNRP1.LT.RCOND ) ) THEN IF( RANK.EQ.1 ) THEN RNKDTD = .TRUE. IF( ABS( A( 1, 1 ) ).EQ.ZERO ) THEN RANK = 0 ORCOND = ZERO SVLUES( IMAX ) = ZERO SVLUES( IBEFOR ) = ZERO SVLUES( IAFTER ) = ZERO SVLUES( IMIN ) = ZERO ELSE RANK = 1 END IF ELSE RNKDTD = .FALSE. GOLEFT = .TRUE. RANK = RANK - 1 END IF ELSE RNKDTD = .TRUE. INFO = 2 END IF * * ***************** * * Start of Loop * * ***************** * * Loop for the detection of the actual rank. The variable RANK is * updated until the rank is found. To avoid infinite loops, the * variable RANK either increases or decreases. * 10 CONTINUE IF( .NOT. RNKDTD ) THEN * * Call to xTRQYC to get tighter bounds for the value RANK. * CALL ZTRQYC( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ RANK, SVLUES, RCNR, RCNRP1, WORK, RWORK, INFO ) IF( INFO.NE.0 ) $ OINFO = INFO * * Check if the numerical rank is larger, equal or smaller than * the contents of RANK. * IF( ( ( RCNR.GE.RCOND ).AND.( RANK.EQ.MN ) ).OR. $ ( ( RCNR.GE.RCOND ).AND.( RCNRP1.LT.RCOND ) ) ) THEN RNKDTD = .TRUE. ELSE IF( ( RCNR.GE.RCOND ).AND.( RCNRP1.GE.RCOND ) ) THEN IF( .NOT. GOLEFT ) THEN RANK = RANK + 1 ELSE RNKDTD = .TRUE. INFO = 2 END IF ELSE IF( ( RCNR.LT.RCOND ).AND.( RCNRP1.LT.RCOND ) ) THEN IF( RANK.EQ.1 ) THEN RNKDTD = .TRUE. IF( ABS( A( 1, 1 ) ).EQ.ZERO ) THEN RANK = 0 ORCOND = ZERO SVLUES( IMAX ) = ZERO SVLUES( IBEFOR ) = ZERO SVLUES( IAFTER ) = ZERO SVLUES( IMIN ) = ZERO ELSE RANK = 1 END IF ELSE GOLEFT = .TRUE. RANK = RANK - 1 END IF ELSE RNKDTD = .TRUE. INFO = 2 END IF * * Jump to the beginning of the loop. * GOTO 10 END IF * * *************** * * end of loop * * *************** * * Give back the obtained value of RCOND and check the value of INFO. * ORCOND = RCNR IF( OINFO.NE.0 ) $ INFO = OINFO * RETURN * * End of ZTRQPY * END SHAR_EOF fi # end of overwriting check if test -f 'ztrqxc.f' then echo shar: will not over-write existing file "'ztrqxc.f'" else cat << SHAR_EOF > 'ztrqxc.f' SUBROUTINE ZTRQXC( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ RANK, SVLUES, RCNR, RCNRP1, WORK, RWORK, INFO ) * * This code is part of a release of the package for computing * rank-revealing QR Factorizations written by: * ================================================================== * Christian H. Bischof and Gregorio Quintana-Orti * Math. and Comp. Sci. Div. Departamento de Informatica * Argonne National Lab. Universidad Jaime I * Argonne, IL 60439 Campus P. Roja, 12071 Castellon * USA Spain * bischof@mcs.anl.gov gquintan@inf.uji.es * ================================================================== * $Revision: 1.42 $ * $Date: 96/12/30 16:59:43 $ * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, RANK, INFO DOUBLE PRECISION RCNR, RCNRP1 * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), C( LDC, * ), WORK( * ) DOUBLE PRECISION SVLUES( 4 ), RWORK( * ) INTEGER JPVT( * ) * .. * * Purpose * ======= * * ZTRQXC carries out an algorithm related to algorithm Hybrid-III * by Chandrasekaran and Ipsen for the stage RANK. The algorithm used * here offers the following advantages: * o It is faster since it is based on Chan-II instead of Stewart-II. * o This algorithm uses the F factor technique to reduce the number of * cycling problems due to roundoff errors. * o The final steps that do not improve the ordering are saved. * * Arguments * ========= * * JOB (input) INTEGER * The job to do: * = 1: The transformations needed in the * triangularization are only applied to matrix A. * Thus, matrix C is not updated. * = 2: The same transformations needed in the * triangularization of matrix A are applied to * matrix C from the left. * That is, if Q'*A*P=R, then C := Q'*C. * In this case, matrix C is m-by-k. * = 3: The transpose of the transformations needed * in the triangularization of matrix A are applied * to matrix C from the right. * That is, if Q'*A*P=R, then C := C*Q. * In this case, matrix C is k-by-m. * In these three cases, the permutations are always stored * in vector JPVT. * * M (input) INTEGER * The number of rows of matrices A. M >= 0. * If JOB=2, M is the number of rows of matrix C. * If JOB=3, M is the number of columns of matrix C. * * N (input) INTEGER * The number of columns of matrix A. N >= 0. * * K (input) INTEGER * It defines the dimension of matrix C. K >= 0. * If JOB=2, K is the number of columns of matrix C. * If JOB=3, K is the number of rows of matrix C. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the m by n matrix A. * On exit, the upper triangle of the array contains the * min(m,n) by n upper trapezoidal matrix R; the lower triangle * array is filled with zeros. * * LDA (input) INTEGER * The leading dimension of array A. LDA >= max(1,M). * * C (input/output) COMPLEX*16 array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the transformations * applied to matrix A are also applied to matrix C. * * LDC (input) INTEGER * The leading dimension of array C. * If JOB=2, then LDC >= MAX(1,M). * If JOB=3, then LDC >= MAX(1,K). * * JPVT (input/output) INTEGER array, dimension ( N ) * If JPVT(I) = K, then the Ith column of the permuted * A was the Kth column of the original A (just before * the preprocessing). If a permutation occurs, JPVT will * be updated correctly. * * RANK (input) INTEGER * The estimate of the rank. 1 <= RANK <= MIN(M,N). * * SVLUES (output) DOUBLE PRECISION array, dimension (4) * On exit, SVLUES contains estimates of some of the singular * values of the triangular factor R. * SVLUES(1): largest singular value of R(1:RANK,1:RANK) * SVLUES(2): smallest singular value of R(1:RANK,1:RANK) * SVLUES(3): smallest singular value of R(1:RANK+1,1:RANK+1) * SVLUES(4): smallest singular value of R * If the triangular factorization is a rank-revealing one * (which will be the case if the leading columns were well- * conditioned), then SVLUES(1) will also be an estimate * for the largest singular value of A, SVLUES(2) and SVLUES(3) * will be estimates for the RANK-th and (RANK+1)-st singular * value of A, and SVLUES(4) wil be an estimate for the * smallest singular value of A. * By examining these values, one can confirm that the rank is * well defined with respect to the threshold chosen. * * RCNR (output) DOUBLE PRECISION * The estimate for the inverse of the condition number of * block R(1:RANK,1:RANK). * * RCNRP1 (output) DOUBLE PRECISION * The estimate for the inverse of the condition number of * block R(1:RANK+1,1:RANK+1). * * WORK (workspace) COMPLEX*16 array, dimension ( 2*MIN(M,N) ). * * RWORK (workspace) DOUBLE PRECISION array, dimension ( MIN(M,N)+N ). * * INFO (output) INTEGER * = 0: Successful exit. * < 0: If info = -i, the i-th argument had an illegal value. * = 4: Exceeded the allowed maximum number of steps. That is, * the matrix presents a slow convergence. * * * =================================================================== * * .. Parameters .. DOUBLE PRECISION F COMPLEX*16 CONE PARAMETER ( F = 0.5D+0, CONE = ( 1.0D+0, 0.0D+0 ) ) * * Indices into the 'svlues' array. * INTEGER IMAX, IBEFOR, IAFTER, IMIN PARAMETER ( IMAX = 1, IBEFOR = 2, IAFTER = 3, IMIN = 4 ) * .. * .. Local Scalars .. DOUBLE PRECISION SMAX, SMAXPR, SMIN, SMINPR, SMXRP1 COMPLEX*16 COSINE, SINE LOGICAL PERMUT INTEGER J, MN, MXSTPS, NACPTD INTEGER NS * .. * .. External Subroutines .. EXTERNAL ZSCAL * .. * .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DLASMX, DZNRM2 EXTERNAL IDAMAX, DLASMX, DZNRM2 * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * MN = MIN( M, N ) NS = 0 MXSTPS = N + 25 INFO = 0 * * Quick return if possible. * IF( MN.EQ.0 ) $ RETURN * * Inicialization of variable NACPTD, which controls main loop. * NACPTD = 0 * * Compute the norms of block A(1:RANK,1:RANK) and store them * in vector RWORK(1:RANK). It is computed only once at the * beginning and updated every iteration. It is used to estimate * the largest singular value in order to pass it to Chan-II. * DO 10 J = 1, RANK RWORK( J ) = DZNRM2( J, A( 1, J ), 1 ) 10 CONTINUE * * ***************** * * start of loop * * ***************** * 20 CONTINUE * * *-*-*-*-*-*-*-*-*-*-*-*-* * * call to Golub-I(rank) * * *-*-*-*-*-*-*-*-*-*-*-*-* * IF( NACPTD.LT.4 ) THEN * * Apply Golub-I for the stage RANK. * CALL ZGLBIF( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ F, RANK, PERMUT, WORK, RWORK( MN+1 ), INFO ) * * If necessary, update the contents of WORK(RANK). * IF( PERMUT ) $ RWORK( RANK ) = DZNRM2( RANK, A( 1, RANK ), 1 ) * * Update variables NACPTD and NS. * IF( PERMUT ) THEN NACPTD = 1 ELSE NACPTD = NACPTD+1 END IF NS = NS + 1 END IF * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * call to Golub-I(rank+1) * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * IF( NACPTD.LT.4 ) THEN * * Determine if the application of Golub-I(rank+1) is necessary. * IF( RANK.EQ.MN ) THEN * * Not necessary. Therefore, no permutation occurs. * PERMUT = .FALSE. ELSE * * Apply Golub-I for the stage RANK+1. * CALL ZGLBIF( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ F, RANK+1, PERMUT, WORK, RWORK( MN+1 ), INFO ) * * Update variable NS. * NS = NS+1 END IF * * Update variable NACPTD. * IF( PERMUT ) THEN NACPTD = 1 ELSE NACPTD = NACPTD+1 END IF END IF * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * call to Chan-II (rank+1)* * *-*-*-*-*-*-*-*-*-*-*-*-*-* * IF( NACPTD.LT.4 ) THEN * * Determine if the application of Chan-II(rank+1) is necessary. * IF( RANK.EQ.MN ) THEN * * Not necessary. Therefore, no permutation occurs. * PERMUT = .FALSE. ELSE * * Extend vector WORK(1:RANK) to vector WORK(1:RANK+1). * So, pivoting vector WORK(1:N) inside Chan-II will be * easier. * RWORK( RANK+1 ) = DZNRM2( RANK+1, A( 1, RANK+1 ), 1 ) * * Apply Chan-II for the stage RANK+1 * on block A(1:RANK+1,1:RANK+1). * CALL ZCNIIF( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ RWORK, F, RANK+1, PERMUT, WORK, $ RWORK( MN+1 ), INFO ) * * Update variable NS. * NS = NS+1 END IF * * Update variable NACPTD. * IF( PERMUT ) THEN NACPTD = 1 ELSE NACPTD = NACPTD+1 END IF END IF * * *-*-*-*-*-*-*-*-*-*-*-*-* * * call to Chan-II(rank) * * *-*-*-*-*-*-*-*-*-*-*-*-* * IF( NACPTD.LT.4 ) THEN * * Apply Chan-II for the stage RANK on block A(1:RANK,1:RANK). * CALL ZCNIIF( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ RWORK, F, RANK, PERMUT, WORK, $ RWORK( MN+1 ), INFO ) * * Update variables NACPTD and NS. * IF( PERMUT ) THEN NACPTD = 1 ELSE NACPTD = NACPTD+1 END IF NS = NS + 1 END IF * * Check if loop must finish. * IF( NS.GE.MXSTPS ) THEN INFO = 1 ELSE IF( NACPTD.LT.4 ) THEN GOTO 20 END IF * * *************** * * end of loop * * *************** * * Computation of the largest singular value of A(1:RANK,1:RANK). * SMAX = ABS( A( 1, 1 ) ) WORK( 1 ) = CONE SMIN = SMAX WORK( MN+1 ) = CONE * DO 30 J = 2, RANK CALL ZLAIC1( 1, J-1, WORK( 1 ), SMAX, $ A( 1, J ), A( J, J ), SMAXPR, SINE, COSINE ) CALL ZSCAL( J-1, SINE, WORK( 1 ), 1 ) WORK( J ) = COSINE SMAX = SMAXPR CALL ZLAIC1( 2, J-1, WORK( MN+1 ), SMIN, $ A( 1, J ), A( J, J ), SMINPR, SINE, COSINE ) CALL ZSCAL( J-1, SINE, WORK( MN+1 ), 1 ) WORK( MN+J ) = COSINE SMIN = SMINPR 30 CONTINUE SVLUES( IMAX ) = SMAX SVLUES( IBEFOR ) = SMIN * * Computation of the largest singular value and the smallest * singular value of A(1:RANK+1,1:RANK+1). * IF( RANK.LT.MN ) THEN CALL ZLAIC1( 1, RANK, WORK( 1 ), SMAX, $ A( 1, RANK+1 ), A( RANK+1, RANK+1 ), SMAXPR, $ SINE, COSINE ) SMAX = SMAXPR CALL ZLAIC1( 2, RANK, WORK( MN+1 ), SMIN, $ A( 1, RANK+1 ), A( RANK+1, RANK+1 ), SMINPR, $ SINE, COSINE ) CALL ZSCAL( RANK, SINE, WORK( MN+1 ), 1 ) WORK( MN+RANK+1 ) = COSINE SMIN = SMINPR END IF SMXRP1 = SMAX SVLUES( IAFTER ) = SMIN * * Computation of the smallest singular value of A(1:MN,1:MN). * DO 40 J = RANK+2, MN CALL ZLAIC1( 2, J-1, WORK( MN+1 ), SMIN, $ A( 1, J ), A( J, J ), SMINPR, SINE, COSINE ) CALL ZSCAL( J-1, SINE, WORK( MN+1 ), 1 ) WORK( MN+J ) = COSINE SMIN = SMINPR 40 CONTINUE SVLUES( IMIN ) = SMIN * * Computation of RCNR and RCNRP1. * RCNR = SVLUES( IBEFOR ) / SVLUES( IMAX ) RCNRP1 = SVLUES( IAFTER ) / SMXRP1 RETURN * * End of ZTRQXC * END SUBROUTINE ZGLBIF( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ F, RANK, PERMUT, WORK, RWORK, INFO ) * * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, RANK, INFO DOUBLE PRECISION F LOGICAL PERMUT * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), C( LDC, * ), WORK( * ) DOUBLE PRECISION RWORK( * ) INTEGER JPVT( * ) * .. * * Purpose * ======= * * ZGLBIF computes the column index of A(RANK:M,RANK:N) with largest * norm and determines if pivoting is necessary. If so, it pivots it * into column RANK, permuts vector JPVT, adjusts vector VNORM and * permuts and retriangularizes matrix A. It does only one permutation. * * Arguments * ========= * * JOB (input) INTEGER * The job to do: * = 1: The transformations needed in the * triangularization are only applied to matrix A. * Thus, matrix C is not updated. * = 2: The same transformations needed in the * triangularization of matrix A are applied to * matrix C from the left. * That is, if Q'*A*P=R, then C := Q'*C. * In this case, matrix C is m-by-k. * = 3: The transpose of the transformations needed * in the triangularization of matrix A are applied * to matrix C from the right. * That is, if Q'*A*P=R, then C := C*Q. * In this case, matrix C is k-by-m. * In these three cases, the permutations are always stored * in vector JPVT. * * M (input) INTEGER * The number of rows of matrices A. M >= 0. * If JOB=2, M is the number of rows of matrix C. * If JOB=3, M is the number of columns of matrix C. * * N (input) INTEGER * The number of columns of matrix A. N >= 0. * * K (input) INTEGER * It defines the dimension of matrix C. K >= 0. * If JOB=2, K is the number of columns of matrix C. * If JOB=3, K is the number of rows of matrix C. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the m by n matrix A. * On exit, the upper triangle of the array contains the * min(m,n) by n upper trapezoidal matrix R; the lower triangle * array is filled with zeros. * * LDA (input) INTEGER * The leading dimension of array A. LDA >= max(1,M). * * C (input/output) COMPLEX*16 array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the transformations * applied to matrix A are also applied to matrix C. * * LDC (input) INTEGER * The leading dimension of array C. * If JOB=2, then LDC >= MAX(1,M). * If JOB=3, then LDC >= MAX(1,K). * * JPVT (input/output) INTEGER array, dimension ( N ) * If JPVT(I) = K, then the Ith column of the permuted * A was the Kth column of the original A (just before the * preprocessing). If a permutation occurs, it will be * updated correctly. * * F (input) DOUBLE PRECISION * F factor for the pivoting. It must be always 0 < f <= 1. * * RANK (input) INTEGER * The estimate for the rank. 1 <= RANK <= MIN(M,N). * * PERMUT (output) LOGICAL * Tells if a permutation occurred. * * WORK (workspace) COMPLEX*16 array, dimension ( MIN(M,N) ) * * RWORK (workspace) DOUBLE PRECISION array, dimension ( N ) * * INFO (output) INTEGER * = 0: Successful exit. * < 0: If info = -i, the i-th argument had an illegal value. * * ===================================================================== * * .. Parameters .. * .. * .. Local Scalars .. INTEGER MN, JJ, J, ITEMP * .. * .. Local Scalars .. COMPLEX*16 CDUMMY( 1, 1 ) * .. * .. External Subroutines .. EXTERNAL ZCOPY, ZGRET * .. * .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DZNRM2 EXTERNAL IDAMAX, DZNRM2 * .. * .. Executable Statements .. * MN = MIN( M, N ) INFO = 0 * * Quick return if possible. * IF( ( MN.EQ.0 ).OR.( RANK.EQ.N ) ) THEN PERMUT = .FALSE. RETURN END IF * * Compute the norms of the columns of block A(RANK:M,RANK:N) * and store them in vector RWORK(RANK:N). * DO 10 J = RANK, N RWORK( J ) = $ DZNRM2( MIN( M, J )-RANK+1, A( RANK, J ), 1 ) 10 CONTINUE * * Find column with largest two-norm of upper triangular block * A(RANK:M,RANK:N). Use the data stored in vector RWORK(RANK:N). * JJ = RANK - 1 + IDAMAX( N-RANK+1, RWORK( RANK ), 1) * * Determine if a permutation must occur. * PERMUT = ( ( JJ.GT.RANK ).AND. $ ( ( ABS( RWORK( JJ ) )*F ).GT.ABS( RWORK( RANK ) ) ) ) * IF( PERMUT ) THEN * * Exchage cyclically to the right the columns of matrix A * between RANK and JJ. That is, RANK->RANK+1, * RANK+1->RANK+2,...,JJ-1->JJ,JJ->K. Use vector WORK(1:MN) * to store temporal data. * CALL ZCOPY( MIN( MN, JJ ), A( 1, JJ ), 1, WORK, 1 ) DO 20 J = JJ-1, RANK, -1 CALL ZCOPY( MIN( MN, J+1 ), A( 1, J ), 1, $ A( 1, J+1 ), 1 ) 20 CONTINUE CALL ZCOPY( MIN( MN, JJ ), WORK, 1, A( 1, RANK ), 1 ) * * Exchange in the same way vector JPVT. * ITEMP = JPVT( JJ ) DO 30 J = JJ-1, RANK, -1 JPVT( J+1 ) = JPVT( J ) 30 CONTINUE JPVT( RANK ) = ITEMP * * Retriangularize matrix A after the permutation. * IF( JOB.EQ.1 ) THEN CALL ZGRET( JOB, MIN( M, JJ )-RANK+1, N-RANK+1, K, $ A( RANK, RANK ), LDA, CDUMMY, 1, $ WORK, RWORK, INFO ) ELSE IF( JOB.EQ.2 ) THEN CALL ZGRET( JOB, MIN( M, JJ )-RANK+1, N-RANK+1, K, $ A( RANK, RANK ), LDA, C( RANK, 1 ), LDC, $ WORK, RWORK, INFO ) ELSE IF( JOB.EQ.3 ) THEN CALL ZGRET( JOB, MIN( M, JJ )-RANK+1, N-RANK+1, K, $ A( RANK, RANK ), LDA, C( 1, RANK ), LDC, $ WORK, RWORK, INFO ) END IF END IF RETURN * * End of ZGLBIF * END SUBROUTINE ZCNIIF( JOB, M, N, K, A, LDA, C, LDC, JPVT, VNORM, $ F, RANK, PERMUT, WORK, RWORK, INFO ) * * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, RANK, INFO DOUBLE PRECISION F LOGICAL PERMUT * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), C( LDC, * ), WORK( * ) DOUBLE PRECISION VNORM( * ), RWORK( * ) INTEGER JPVT( * ) * .. * * Purpose * ======= * * ZCNIIF computes the "worst" column in A(1:RANK,1:RANK) and * determines if pivoting is necessary. If so, it pivots it into column * RANK, permuts vector JPVT, adjusts vector VNORM and permuts and * retriangularizes matrix A. It does only one permutation. * * Arguments * ========= * * JOB (input) INTEGER * The job to do: * = 1: The transformations needed in the * triangularization are only applied to matrix A. * Thus, matrix C is not updated. * = 2: The same transformations needed in the * triangularization of matrix A are applied to * matrix C from the left. * That is, if Q'*A*P=R, then C := Q'*C. * In this case, matrix C is m-by-k. * = 3: The transpose of the transformations needed * in the triangularization of matrix A are applied * to matrix C from the right. * That is, if Q'*A*P=R, then C := C*Q. * In this case, matrix C is k-by-m. * In these three cases, the permutations are always stored * in vector JPVT. * * M (input) INTEGER * The number of rows of matrices A. M >= 0. * If JOB=2, M is the number of rows of matrix C. * If JOB=3, M is the number of columns of matrix C. * * N (input) INTEGER * The number of columns of matrix A. N >= 0. * * K (input) INTEGER * It defines the dimension of matrix C. K >= 0. * If JOB=2, K is the number of columns of matrix C. * If JOB=3, K is the number of rows of matrix C. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the m by n matrix A. * On exit, the upper triangle of the array contains the * min(m,n) by n upper trapezoidal matrix R; the lower triangle * array is filled with zeros. * * LDA (input) INTEGER * The leading dimension of array A. LDA >= MAX(1,M). * * C (input/output) COMPLEX*16 array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the transformations * applied to matrix A are also applied to matrix C. * * LDC (input) INTEGER * The leading dimension of array C. * If JOB=2, then LDC >= MAX(1,M). * If JOB=3, then LDC >= MAX(1,K). * * JPVT (input/output) INTEGER array, dimension (N) * If JPVT(I) = K, then the Ith column of the permuted * A was the Kth column of the original A (just before the * preprocessing). If a permutation occurs, this vector will * be updated correctly. * * VNORM (input/output) DOUBLE PRECISION array, dimension ( N ) * VNORM(1:RANK) contains the norms of the columns of upper * triangular block A(1:RANK,1:RANK). If a permutation occurs, * this vector will be updated correctly. * * F (input) DOUBLE PRECISION * F factor for the pivoting. It must be always 0 < f <= 1. * * RANK (input) INTEGER * The estimate for the rank. 1 <= RANK <= MIN(M,N). * * PERMUT (output) LOGICAL * Tells if a permutation occurred. * * WORK (workspace) COMPLEX*16 array, dimension ( MIN(M,N) ) * * RWORK (workspace) DOUBLE PRECISION array, dimension ( MIN(M,N) ) * * INFO (output) INTEGER * = 0: Successful exit. * < 0: If info = -i, the i-th argument had an illegal value. * * Further Details * =============== * * If block R(1:RANK,1:RANK) is singular or near singular, there will * be no permutation because in that case the right (and left) singular * vectors are the canonical ones ((0,0,...0,1)^T). * That is, there will not be permutation if * RCOND <= SF * DLAMCH('Safe Minimum'), where SF (Safe Factor) is * a security factor to avoid arithmetic exceptions. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION SF PARAMETER ( SF = 1.0D+2 ) COMPLEX*16 CONE PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER MN, JJ, J, ITEMP DOUBLE PRECISION SMAX, SMIN, SMINPR, TEMP COMPLEX*16 SINE, COSINE * .. * .. Local Arrays .. COMPLEX*16 CDUMMY( 1, 1 ) * .. * .. External Subroutines .. EXTERNAL ZCOPY, ZTRSV, ZHESS * .. * .. External Functions .. INTEGER IDAMAX, IZAMAX DOUBLE PRECISION DZNRM2, DLAMCH, DLASMX EXTERNAL IDAMAX, IZAMAX, DZNRM2, $ DLAMCH, DLASMX * .. * .. Executable Statements .. * MN = MIN( M, N ) INFO = 0 * * Quick return if possible. * IF( ( MN.EQ.0 ).OR.( RANK.EQ.1 ) ) THEN PERMUT = .FALSE. RETURN END IF * * Estimation of the largest singular value of block * A(1:RANK,1:RANK) by using the contents of vector * VNORM. * ITEMP = IDAMAX( RANK, VNORM, 1 ) SMAX = DLASMX( RANK ) * VNORM( ITEMP ) * * Estimation of the smallest singular value of block * A(1:RANK,1:RANK) and its corresponding left singular vector. * Save left singular vector in vector WORK(1:RANK). * SMIN = ABS( A( 1, 1 ) ) WORK( 1 ) = CONE DO 10 J = 2, RANK CALL ZLAIC1( 2, J-1, WORK( 1 ), SMIN, A( 1, J ), $ A( J , J ), SMINPR, SINE, COSINE ) CALL ZSCAL( J-1, SINE, WORK( 1 ), 1 ) WORK( J ) = COSINE SMIN = SMINPR 10 CONTINUE * * Determine if matrix A(1:RANK,1:RANK) is singular or nearly * singular. SF (Safe Factor) is used to say if it is singular or not. * IF( SMIN.LE.( SMAX*SF*DLAMCH( 'Safe minimum' ) ) ) THEN * * Singular or nearly singular matrix. Its right singular * vector is (0,0,...,0,1)^T. So, no pivoting is needed. * PERMUT = .FALSE. ELSE * * Follow usual method: Estimate the right singular vector * corresponding to the smallest singular value of upper * triangular block A(1:RANK,1:RANK) and store in vector * WORK(1:RANK). * CALL ZTRSV( 'Upper', 'No transpose', 'No unit', $ RANK, A, LDA, WORK, 1) * * Find the index with largest absolute value in vector * WORK(1:RANK). * JJ = IZAMAX( RANK, WORK, 1 ) * * Determine if a permutation must occur. * PERMUT = ( ( JJ.LT.RANK ).AND. $ ( ( ABS( WORK( JJ ) )*F ).GT.ABS( WORK( RANK ) ) ) ) * IF( PERMUT ) THEN * * Exchange cyclically to the left the colums of matrix A * between JJ and RANK. That is, JJ->RANK,JJ+1->JJ,..., * RANK->RANK-1. Use vector WORK to store temporal data. * CALL ZCOPY( RANK, A( 1, JJ ), 1, WORK, 1 ) DO 20 J = JJ+1, RANK CALL ZCOPY( J, A( 1, J ), 1, A( 1, J-1 ), 1 ) 20 CONTINUE CALL ZCOPY( RANK, WORK, 1, A( 1, RANK ), 1 ) * * Exchange in the same way vector JPVT. * ITEMP = JPVT( JJ ) DO 30 J = JJ+1, RANK JPVT( J-1 ) = JPVT( J ) 30 CONTINUE JPVT( RANK ) = ITEMP * * Adjust the contents of VNORM. * TEMP = VNORM( JJ ) DO 40 J = JJ+1, RANK VNORM( J-1 ) = VNORM( J ) 40 CONTINUE VNORM( RANK ) = TEMP * * Retriangularize matrix A after the permutation. * IF( JOB.EQ.1 ) THEN CALL ZHESS( JOB, RANK-JJ+1, N-JJ+1, K, $ A( JJ, JJ ), LDA, CDUMMY, 1, $ WORK, RWORK, INFO ) ELSE IF( JOB.EQ.2 ) THEN CALL ZHESS( JOB, RANK-JJ+1, N-JJ+1, K, $ A( JJ, JJ ), LDA, C( JJ, 1 ), LDC, $ WORK, RWORK, INFO ) ELSE IF( JOB.EQ.3 ) THEN CALL ZHESS( JOB, RANK-JJ+1, N-JJ+1, K, $ A( JJ, JJ ), LDA, C( 1, JJ ), LDC, $ WORK, RWORK, INFO ) END IF END IF END IF RETURN * * End of ZCNIIF * END SUBROUTINE ZGRET( JOB, M, N, K, A, LDA, C, LDC, $ WORK, RWORK, INFO ) * * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, INFO * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), C( LDC, * ), WORK( * ) DOUBLE PRECISION RWORK( * ) * .. * * Purpose * ======= * * ZGRET retriangularizes a special matrix. This has the following * features: its first column is non-zero and its main diagonal is zero * except the first element. Now it is showed a 4 by 8 small example: * x x x x x x x x * x 0 x x x x x x * x 0 0 x x x x x * x 0 0 0 x x x x * This subroutine assumes that in all cases N>=M. * The transformations applied to matrix A can be also * applied to matrix C. * * Parameters * ========== * * JOB (input) INTEGER * The job to do: * = 1: The transformations needed in the * triangularization are only applied to matrix A. * Thus, matrix C is not updated. * = 2: The same transformations needed in the * triangularization of matrix A are applied to * matrix C from the left. * That is, if Q'*A*P=R, then C := Q'*C. * In this case, matrix C is m-by-k. * = 3: The transpose of the transformations needed * in the triangularization of matrix A are applied * to matrix C from the right. * That is, if Q'*A*P=R, then C := C*Q. * In this case, matrix C is k-by-m. * In these three cases, the permutations are always stored * in vector JPVT. * * M (input) INTEGER * The number of rows of matrices A. M >= 0. * If JOB=2, M is the number of rows of matrix C. * If JOB=3, M is the number of columns of matrix C. * * N (input) INTEGER * The number of columns of matrix A. N >= 0. * * K (input) INTEGER * It defines the dimension of matrix C. K >= 0. * If JOB=2, K is the number of columns of matrix C. * If JOB=3, K is the number of rows of matrix C. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the m by n matrix A. * On exit, the upper triangle of the array contains the * min(m,n) by n upper trapezoidal matrix R; the lower triangle * array is filled with zeros. * * LDA (input) INTEGER * The leading dimension of array A. LDA >= max(1,M). * * C (input/output) COMPLEX*16 array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the transformations * applied to matrix A are also applied to matrix C. * * LDC (input) INTEGER * The leading dimension of array C. * If JOB=2, then LDC >= MAX(1,M). * If JOB=3, then LDC >= MAX(1,K). * * WORK (workspace) COMPLEX*16 array, dimension ( M ) * * RWORK (workspace) DOUBLE PRECISION array, dimension ( M ) * * INFO (output) INTEGER * = 0: Successful exit. * < 0: If info = -i, the i-th argument had an illegal value. * * ===================================================================== * * .. Parameters .. COMPLEX*16 CZERO PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Common Blocks .. INTEGER NB COMMON /BSPRQR/ NB * .. * .. Local Scalars .. INTEGER I, J, JB, ITEMP DOUBLE PRECISION COSINE COMPLEX*16 R, SINE * .. * .. External Subroutines .. EXTERNAL ZLARTG, ZROT * .. * .. Intrinsic Functions .. INTRINSIC MIN, DCONJG * .. * .. Executable Statements .. * INFO = 0 * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( M.EQ.1 ).OR.( N.EQ.0 ) ) $ RETURN IF( NB.GT.1 ) THEN * * Block Algorithm * =============== * * Compute Givens Rotations needed to nullify the first column * of matrix A and apply on the fly to that column. Store * temporally the sine and cosine of the angles of the applied * Givens Rotations in vectors WORK and RWORK. * DO 10 I = M, 2, -1 CALL ZLARTG( A( I-1, 1 ), A( I, 1 ), $ RWORK( I ), WORK( I ), R ) A( I-1, 1 ) = R A( I, 1 ) = CZERO 10 CONTINUE * * Apply the previously computed Givens Rotations to the rest * of matrix A. * DO 20 J = 2, N, NB JB = MIN( NB, N-J+1 ) DO 30 I = MIN( M, J+JB-1 ), J, -1 CALL ZROT( J+JB-I, A( I-1, I ), LDA, A( I, I ), LDA, $ RWORK( I ), WORK( I ) ) 30 CONTINUE DO 40 I = MIN( M, J-1 ), 2, -1 CALL ZROT( JB, A( I-1, J ), LDA, A( I, J ), LDA, $ RWORK( I ), WORK( I ) ) 40 CONTINUE 20 CONTINUE * * Update the corresponding part of matrix C. * IF( ( JOB.EQ.2 ).AND.( K.GT.0 ) ) THEN * * Apply the previously computed rotations from the left. * DO 50 J = 1, K, NB JB = MIN( NB, K-J+1 ) DO 60 I = M, 2, -1 CALL ZROT( JB, C( I-1, J ), LDC, C( I, J ), LDC, $ RWORK( I ), WORK( I ) ) 60 CONTINUE 50 CONTINUE ELSE IF( ( JOB.EQ.3 ).AND.( K.GT.0 ) ) THEN * * Apply the transpose of the previously computed rotations * from the right. * DO 70 I = M, 2, -1 CALL ZROT( K, C( 1, I-1 ), 1, C( 1, I ), 1, $ RWORK( I ), DCONJG( WORK( I ) ) ) 70 CONTINUE END IF ELSE * * Non-Block Algorithm * =================== * DO 90 I = M, 2, -1 ITEMP = I - 1 * * Compute the rotation parameters and update column 1 of A. * CALL ZLARTG( A( ITEMP, 1 ), A( I , 1 ), COSINE, SINE, R ) A( ITEMP, 1 ) = R A( I, 1 ) = CZERO * * Update columns I:N of matrix A. * CALL ZROT( N-I+1, A( ITEMP, I ), LDA, A( I, I ), LDA, $ COSINE, SINE ) * * Update the corresponding part of matrix C. * IF( ( JOB.EQ.2 ).AND.( K.GT.0 ) ) THEN * * Apply the previously computed rotations from the left. * CALL ZROT( K, C( ITEMP, 1 ), LDC, C( I, 1 ), LDC, $ COSINE, SINE ) ELSE IF( ( JOB.EQ.3 ).AND.( K.GT.0 ) ) THEN * * Apply the transpose of the previously computed rotations * from the right. * CALL ZROT( K, C( 1, ITEMP ), 1, C( 1, I ), 1, $ COSINE, DCONJG( SINE ) ) END IF 90 CONTINUE END IF RETURN * * End of ZGRET * END SUBROUTINE ZHESS( JOB, M, N, K, A, LDA, C, LDC, $ WORK, RWORK, INFO ) * * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, INFO * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), C( LDC, * ), WORK( * ) DOUBLE PRECISION RWORK( * ) * .. * * Purpose * ======= * * ZHESS reduces the upper hessemberg matrix A to upper triangular form. * applied to matrix C if argument JOB asks. * This subroutine assumes that in all cases N>=M. * * Parameters * ========== * * JOB (input) INTEGER * The job to do: * = 1: The transformations needed in the * triangularization are only applied to matrix A. * Thus, matrix C is not updated. * = 2: The same transformations needed in the * triangularization of matrix A are applied to * matrix C from the left. * That is, if Q'*A*P=R, then C := Q'*C. * In this case, matrix C is m-by-k. * = 3: The transpose of the transformations needed * in the triangularization of matrix A are applied * to matrix C from the right. * That is, if Q'*A*P=R, then C := C*Q. * In this case, matrix C is k-by-m. * In these three cases, the permutations are always stored * in vector JPVT. * * M (input) INTEGER * The number of rows of matrices A. M >= 0. * If JOB=2, M is the number of rows of matrix C. * If JOB=3, M is the number of columns of matrix C. * * N (input) INTEGER * The number of columns of matrix A. N >= 0. * * K (input) INTEGER * It defines the dimension of matrix C. K >= 0. * If JOB=2, K is the number of columns of matrix C. * If JOB=3, K is the number of rows of matrix C. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the m by n matrix A. * On exit, the upper triangle of the array contains the * min(m,n) by n upper trapezoidal matrix R; the lower triangle * array is filled with zeros. * * LDA (input) INTEGER * The leading dimension of array A. LDA >= max(1,M). * * C (input/output) COMPLEX*16 array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the transformations * applied to matrix A are also applied to matrix C. * * LDC (input) INTEGER * The leading dimension of array C. * If JOB=2, then LDC >= MAX(1,M). * If JOB=3, then LDC >= MAX(1,K). * * WORK (workspace) COMPLEX*16 array, dimension ( M ) * * RWORK (workspace) DOUBLE PRECISION array, dimension ( M ) * * INFO (output) INTEGER * = 0: Successful exit. * < 0: If info = -i, the i-th argument had an illegal value. * * ===================================================================== * * .. Parameters .. COMPLEX*16 CZERO PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Common Blocks .. INTEGER NB COMMON /BSPRQR/ NB * .. * .. Local Scalars .. INTEGER I, J, ITEMP, JB DOUBLE PRECISION COSINE COMPLEX*16 R, SINE * .. * .. External Subroutines .. EXTERNAL ZLARTG, ZROT * .. * .. Intrinsic Functions .. INTRINSIC MIN, DCONJG * .. * .. Executable Statements .. * INFO = 0 * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( M.EQ.1 ).OR.( N.EQ.0 ) ) $ RETURN IF( NB.GT.1 ) THEN * * Block Algorithm * =============== * * Compute Givens Rotations needed to reduce upper hessenberg * matrix A to triangular form, and apply on the fly those * rotations to matrix. Store temporally the sine and cosine * of the angles of the applied Givens Rotations in * vectors WORK and RWORK. * DO 10 J = 1, N, NB JB = MIN( NB, N-J+1 ) DO 20 I = 2, MIN( M, J ) CALL ZROT( JB, A( I-1, J ), LDA, A( I, J ), LDA, $ RWORK( I ), WORK( I ) ) 20 CONTINUE DO 30 I = J+1, MIN( M, J+JB ) ITEMP = I-1 CALL ZLARTG( A( ITEMP, ITEMP ), A( I, ITEMP ), $ RWORK( I ), WORK( I ), R ) A( ITEMP, ITEMP ) = R A( I, ITEMP ) = CZERO CALL ZROT( J+JB-I, A( ITEMP, I ), LDA, $ A( I, I ), LDA, RWORK( I ), WORK( I ) ) 30 CONTINUE 10 CONTINUE * * Update the corresponding part of matrix C. * IF( ( JOB.EQ.2 ).AND.( K.GT.0 ) ) THEN * * Apply the previously computed rotations from the left. * DO 40 J = 1, K, NB JB = MIN( NB, K-J+1 ) DO 50 I = 2, M CALL ZROT( JB, C( I-1, J ), LDC, C( I, J ), LDC, $ RWORK( I ), WORK( I ) ) 50 CONTINUE 40 CONTINUE ELSE IF( ( JOB.EQ.3 ).AND.( K.GT.0 ) ) THEN * * Apply the transpose of the previously computed rotations * from the right. * DO 60 I = 2, M CALL ZROT( K, C( 1, I-1 ), 1, C( 1, I ), 1, $ RWORK( I ), DCONJG( WORK( I ) ) ) 60 CONTINUE END IF ELSE * * Non-Block Algorithm * =================== * DO 80 I = 2, M ITEMP = I - 1 * * Compute the rotation parameters. * CALL ZLARTG( A( ITEMP, ITEMP ), A( I, ITEMP ), $ COSINE, SINE, R ) * * Update columns I-1:N of matrix A. * A( ITEMP, ITEMP ) = R A( I, ITEMP ) = CZERO CALL ZROT( N-I+1, A( ITEMP, I ), LDA, A( I, I ), LDA, $ COSINE, SINE ) * * Update the corresponding part of matrix C. * IF( ( JOB.EQ.2 ).AND.( K.GT.0 ) ) THEN * * Apply the previously computed rotations from the left. * CALL ZROT( K, C( ITEMP, 1 ), LDC, C( I, 1 ), LDC, $ COSINE, SINE ) ELSE IF( ( JOB.EQ.3 ).AND.( K.GT.0 ) ) THEN * * Apply the transpose of the previously computed rotations * from the right. * CALL ZROT( K, C( 1, ITEMP ), 1, C( 1, I ), 1, $ COSINE, DCONJG( SINE ) ) END IF 80 CONTINUE END IF RETURN * * End of ZHESS * END SHAR_EOF fi # end of overwriting check if test -f 'ztrqyc.f' then echo shar: will not over-write existing file "'ztrqyc.f'" else cat << SHAR_EOF > 'ztrqyc.f' SUBROUTINE ZTRQYC( JOB, M, N, K, A, LDA, C, LDC, JPVT, RANK, $ SVLUES, RCNR, RCNRP1, WORK, RWORK, INFO ) * * This code is part of a release of the package for computing * rank-revealing QR Factorizations written by: * ================================================================== * Christian H. Bischof and Gregorio Quintana-Orti * Math. and Comp. Sci. Div. Departamento de Informatica * Argonne National Lab. Universidad Jaime I * Argonne, IL 60439 Campus P. Roja, 12071 Castellon * USA Spain * bischof@mcs.anl.gov gquintan@inf.uji.es * ================================================================== * $Revision: 1.42 $ * $Date: 96/12/30 16:59:44 $ * * .. Scalars Arguments .. INTEGER JOB, M, N, K, LDA, LDC, RANK, INFO DOUBLE PRECISION RCNR, RCNRP1 * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), C( LDC, * ), WORK( * ) DOUBLE PRECISION SVLUES( 4 ), RWORK( * ) INTEGER JPVT( * ) * .. * * Purpose * ======= * * PREC_TRQYC carries out Pan-Tang Algorithm 3 for the stage RANK. * This is a mofified version of the original algorithm. The improved * features are the following: * o Use of Bischof's ICE to reduce the computational cost. * o Reorganization of the main loop to save computations. * o No permutation is carried out if not strictly needed. * * Arguments * ========= * * JOB (input) INTEGER * The job to do: * = 1: The orthogonal transformations needed in the * triangularization are only applied to matrix A. * Thus, matrix C is not updated. * = 2: The same orthogonal transformations needed in the * triangularization of matrix A are applied to * matrix C from the left. * That is, if Q'*A*P=R, then C := Q'*C. * In this case, matrix C is m-by-k. * = 3: The transpose of the orthogonal transformations needed * in the triangularization of matrix A are applied * to matrix C from the right. * That is, if Q'*A*P=R, then C := C*Q. * In this case, matrix C is k-by-m. * In these three cases, the permutations are always stored * in vector JPVT. * * M (input) INTEGER * The number of rows of matrices A and C. M >= 0. * * N (input) INTEGER * The number of columns of matrix A. N >= 0. * * K (input) INTEGER * The number of columns of matrix C. K >= 0. * * A (input/output) COMPLEX*16 array (LDA,N) * Upper triangular m by n matrix. * * LDA (input) INTEGER * The leading dimension of array A. LDA >= MAX( 1, M ). * * C (input/output) COMPLEX*16 array (LDC,K) * Matrix of dimension m x k where to accumulate * orthogonal transformations from the left. * * LDC (input) INTEGER * The leading dimension of array C. LDC >= MAX( 1, M ). * * JPVT (input/output) INTEGER array (N) * Vector with the actual permutation of matrix A. * * RANK (input) INTEGER * The estimate for the rank. 1 <= RANK <= MIN(M,N). * * SVLUES (output) DOUBLE PRECISION array, dimension (4) * On exit, SVLUES contains estimates of some of the singular * values of the triangular factor R. * SVLUES(1): largest singular value of R(1:RANK,1:RANK) * SVLUES(2): smallest singular value of R(1:RANK,1:RANK) * SVLUES(3): smallest singular value of R(1:RANK+1,1:RANK+1) * SVLUES(4): smallest singular value of R * If the triangular factorization is a rank-revealing one * (which will be the case if the leading columns were well- * conditioned), then SVLUES(1) will also be an estimate * for the largest singular value of A, SVLUES(2) and SVLUES(3) * will be estimates for the RANK-th and (RANK+1)-st singular * value of A, and SVLUES(4) will be an estimate for the * smallest singular value of A. * By examining these values, one can confirm that the rank is * well defined with respect to the threshold chosen. * * RCNR (output) DOUBLE PRECISION * The estimate for the inverse of the condition number of * block R(1:RANK,1:RANK). * * RCNRP1 (output) DOUBLE PRECISION * The estimate for the inverse of the condition number of * block R(1:RANK+1,1:RANK+1). * * WORK (workspace) COMPLEX*16 array, dimension (2*MIN(M,N)) * * RWORK (workspace) DOUBLE PRECISION array, dimension (N+MIN(M,N)) * * INFO (output) INTEGER * = 0: Successful exit. * < 0: If info = -i, the i-th argument had an illegal value. * = 4: Exceeded the allowed maximum number of steps. That is, * the matrix presents a slow convergence. * * * Further Details * =============== * * If the leading block of R is singular or near singular, there will * be no permutation because in that case the right (and left) singular * vectors are the canonical ones ((0,0,...0,1)^T). * That is, there will not be permutation if * RCOND <= SF * DLAMCH('Safe Minimum'), where SF (Safe Factor) is * a security factor to avoid arithmetic exceptions. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION FP, SF COMPLEX*16 CONE PARAMETER ( FP = 0.9D+0, SF = 1.0D+2, $ CONE = ( 1.0D+0, 0.0D+0 ) ) * * Indices into the 'svlues' array. * INTEGER IMAX, IBEFOR, IAFTER, IMIN PARAMETER ( IMAX = 1, IBEFOR = 2, IAFTER = 3, IMIN = 4 ) * .. * .. Local Scalars .. INTEGER I, II, ITEMP, J, JJ, MN, MXSTPS, NCA, NCTBA DOUBLE PRECISION F, RCOS, SMAX, SMAXPR, SMIN, SMINPR, SMXRP1, $ SMNRP1, TEMP COMPLEX*16 COSINE, CTEMP, DIAG, SINE INTEGER NS * .. Local Arrays .. COMPLEX*16 CDUMMY( 1, 1 ) * .. * .. External Subroutines .. EXTERNAL ZCOPY, ZGRET, ZHESS, ZLAIC1, $ ZLARTG, ZSCAL, ZSWAP, ZTRSV * .. * .. External Functions .. EXTERNAL IDAMAX, IZAMAX, DLAMCH, $ DLASMX, DZNRM2 INTEGER IDAMAX, IZAMAX DOUBLE PRECISION DLAMCH, DLASMX, DZNRM2 * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT, DBLE * .. * .. Executable Statements .. MN = MIN( M, N ) MXSTPS = N+25 NS = 0 * * Test input arguments * ==================== * INFO = 0 IF( ( JOB.LT.1 ).OR.( JOB.GT.3 ) ) THEN INFO = -1 ELSE IF( M.LT.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( K.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -6 ELSE IF( ( ( JOB.EQ.1 ).AND.( LDC.LT.1 ) ).OR. $ ( ( JOB.EQ.2 ).AND.( LDC.LT.MAX( 1, M ) ) ).OR. $ ( ( JOB.EQ.3 ).AND.( LDC.LT.MAX( 1, K ) ) ) ) THEN INFO = -8 ELSE IF( ( RANK.LT.1 ).OR.( RANK.GT.MN ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZTRQYC', -INFO ) RETURN END IF * * Quick return if possible. * IF( MN.EQ.0 ) $ RETURN * IF( RANK.EQ.MN ) THEN * * ************************ * ************************ * * Apply Chan Algorithm * * ************************ * ************************ * F = FP * * Move the best column of A(1:M,M:N) to position M-th. * JJ = MN - 1 + IZAMAX( N-MN+1, A( MN, MN ), LDA ) IF( JJ.GT.MN ) THEN CALL ZSWAP( M, A( 1, MN ), 1, A( 1, JJ ), 1 ) ITEMP = JPVT( MN ) JPVT( MN ) = JPVT( JJ ) JPVT( JJ ) = ITEMP END IF * * Estimation of the largest singular value, the smallest * singular value, and its corresponding left singular vector. * SMAX = ABS( A( 1, 1 ) ) WORK( 1 ) = CONE SMIN = SMAX WORK( MN+1 ) = CONE DO 10 J = 2, RANK CALL ZLAIC1( 1, J-1, WORK( 1 ), SMAX, A( 1, J ), $ A( J, J ), SMAXPR, SINE, COSINE ) CALL ZSCAL( J-1, SINE, WORK( 1 ), 1 ) WORK( J ) = COSINE SMAX = SMAXPR * CALL ZLAIC1( 2, J-1, WORK( MN+1 ), SMIN, A( 1, J ), $ A( J, J ), SMINPR, SINE, COSINE ) CALL ZSCAL( J-1, SINE, WORK( MN+1 ), 1 ) WORK( MN+J ) = COSINE SMIN = SMINPR 10 CONTINUE * * Determine if matrix A is singular or nearly singular. * SF (Safe Factor) is used to say whether or not it is. * IF( SMIN.GT.( SMAX*SF*DLAMCH( 'Safe Minimum' ) ) ) THEN * * Matrix is not singular or not nearly singular. * Follow usual method: Estimate the right singular vector * corresponding to the smallest singular value of upper * triangular block A(1:RANK,1:RANK). * CALL ZTRSV( 'Upper', 'No transpose', 'No unit', $ RANK, A, LDA, WORK( MN+1 ), 1 ) * * Find the index with largest absolute value in vector * WORK( MN+1:2*MN ). * JJ = IZAMAX( RANK, WORK( MN+1 ), 1 ) * * Permut if necessary. * IF( ( JJ.LT.RANK ).AND.( ( ABS( WORK( MN+JJ ) )*F ) $ .GT.ABS( WORK( MN+RANK ) ) ) ) THEN * NS = 1 * * Exchange cyclically to the left the columns of A between * JJ and RANK, that is: JJ->RANK, JJ+1->JJ, JJ+2->JJ+1,..., * RANK->RANK-1. * CALL ZCOPY( RANK, A( 1, JJ ), 1, WORK( 1 ), 1 ) DO 20 J = JJ+1, RANK CALL ZCOPY( J, A( 1, J ), 1, A( 1, J-1 ), 1 ) 20 CONTINUE CALL ZCOPY( RANK, WORK( 1 ), 1, A( 1, RANK ), 1 ) * * Exchange in the same way vector JPVT. * ITEMP = JPVT( JJ ) DO 30 J = JJ+1, RANK JPVT( J-1 ) = JPVT( J ) 30 CONTINUE JPVT( RANK ) = ITEMP * * Retriangularization of matrix A after the permutation. * IF( JOB.EQ.1 ) THEN CALL ZHESS( JOB, RANK-JJ+1, N-JJ+1, K, $ A( JJ, JJ ), LDA, CDUMMY, 1, $ WORK( 1 ), RWORK( N+1 ), INFO ) ELSE IF( JOB.EQ.2 ) THEN CALL ZHESS( JOB, RANK-JJ+1, N-JJ+1, K, $ A( JJ, JJ ), LDA, C( JJ, 1 ), LDC, $ WORK( 1 ), RWORK( N+1 ), INFO ) ELSE IF( JOB.EQ.3 ) THEN CALL ZHESS( JOB, RANK-JJ+1, N-JJ+1, K, $ A( JJ, JJ ), LDA, C( 1, JJ ), LDC, $ WORK( 1 ), RWORK( N+1 ), INFO ) END IF END IF END IF * * Computation of the contents of vector SVLUES, RCNR and RCNRP1. * SVLUES( IMAX ) = SMAX SVLUES( IBEFOR ) = SMIN SVLUES( IAFTER ) = SMIN SVLUES( IMIN ) = SMIN RCNR = SVLUES( IBEFOR ) / SVLUES( IMAX ) RCNRP1 = RCNR ELSE * * *************************************** * *************************************** * * Apply Modified Pan&Tang Algorithm 3 * * *************************************** * *************************************** * * Adjust the value of f. * F = FP / SQRT( DBLE( RANK+1 ) ) * * Compute the norms of columns of matrix A. Store them into * vector RWORK(1:N). * DO 100 J = 1, N RWORK( J ) = DZNRM2( MIN( M, J ), A( 1, J ), 1 ) 100 CONTINUE * * Estimate the smallest singular value of A(1:RANK,1:RANK) and * its corresponding left singular vector. * SMIN will contain the smallest singular value and * WORK(1:MN) will contain the left singular vector. * SMIN = ABS( A( 1, 1 ) ) WORK( 1 ) = CONE DO 110 J = 2, RANK CALL ZLAIC1( 2, J-1, WORK( 1 ), SMIN, A( 1, J ), $ A( J , J ), SMINPR, SINE, COSINE ) CALL ZSCAL( J-1, SINE, WORK( 1 ), 1 ) WORK( J ) = COSINE SMIN = SMINPR 110 CONTINUE * * Initialize loop variables. * NCA = 0 NCTBA = N-RANK II = RANK+1 * * *********************** * * Start of Loop WHILE * * *********************** * 1000 IF( ( NCA.LT.NCTBA ).AND.( NS.LT.MXSTPS ) ) THEN * * Estimate the smallest singular value of A(1:RANK+1,1:RANK+1) * and its corresponding left singular vector as if column II * of matrix A were on column RANK+1. * DIAG = A( MIN( MN, II ), II ) DO 120 I = MIN( MN, II )-1, RANK+1, -1 CALL ZLARTG( A( I, II ), DIAG, RCOS, SINE, CTEMP ) DIAG = CTEMP 120 CONTINUE * CALL ZLAIC1( 2, RANK, WORK( 1 ), SMIN, A( 1, II ), $ DIAG, SMNRP1, SINE, COSINE ) IF( SMNRP1.GE.( F*ABS( DIAG ) ) ) THEN * * Column II accepted on the right part of matrix A. * NCA = NCA+1 IF( II.EQ.N ) THEN II = RANK+1 ELSE II = II+1 END IF ELSE * * Column II not accepted on the right part of matrix A. * * *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* * * Permut column II to position RANK+1 * * *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* * * Exchange cyclically to the right the columns of A between * RANK+1 and II, that is, RANK+1->RANK+2, RANK+2->RANK+3, * ...,II-1->II,II->RANK+1. * CALL ZCOPY( MIN( MN, II ), A( 1, II ), 1, $ WORK( MN+1 ), 1 ) DO 130 J = II-1, RANK+1, -1 CALL ZCOPY( MIN( MN, J+1 ), A( 1, J ), 1 , $ A( 1, J+1 ), 1 ) 130 CONTINUE CALL ZCOPY( MIN( MN, II ), WORK( MN+1 ), 1, $ A( 1, RANK+1 ), 1 ) * * Exchange in the same way vector JPVT. * ITEMP = JPVT( II ) DO 140 J = II-1, RANK+1, -1 JPVT( J+1 ) = JPVT( J ) 140 CONTINUE JPVT( RANK+1 ) = ITEMP * * Exchange in the same way vector RWORK(1:N). * TEMP = RWORK( II ) DO 150 J = II-1, RANK+1, -1 RWORK( J+1 ) = RWORK( J ) 150 CONTINUE RWORK( RANK+1 ) = TEMP * * Retriangularize matrix A after permutation. * IF( JOB.EQ.1 ) THEN CALL ZGRET( JOB, MIN( M, II )-RANK, N-RANK, K, $ A( RANK+1, RANK+1 ), LDA, CDUMMY, 1, $ WORK( MN+1 ), RWORK( N+1 ), INFO ) ELSE IF( JOB.EQ.2 ) THEN CALL ZGRET( JOB, MIN( M, II )-RANK, N-RANK, K, $ A( RANK+1, RANK+1 ), LDA, C( RANK+1, 1 ), $ LDC, WORK( MN+1 ), RWORK( N+1 ), INFO ) ELSE IF( JOB.EQ.3 ) THEN CALL ZGRET( JOB, MIN( M, II )-RANK, N-RANK, K, $ A( RANK+1, RANK+1 ), LDA, C( 1, RANK+1 ), $ LDC, WORK( MN+1 ), RWORK( N+1 ), INFO ) END IF * * Estimate the largest singular value. * ITEMP = IDAMAX( RANK+1, RWORK, 1 ) SMXRP1 = DLASMX( RANK+1 )*RWORK( ITEMP ) * * *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* * * Estimate the right singular vector * * *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* * IF( SMNRP1.GT. $ ( SMXRP1*SF*DLAMCH( 'Safe minimum' ) ) ) THEN * * Matrix is not singular or not nearly singular. * * First, end the estimation of the left singular vector. * No problem to access WORK(MN+RANK+1) since RANKRANK+1,JJ+1->JJ, * JJ+2->JJ+1,...,RANK+1->RANK. * CALL ZCOPY( RANK+1, A( 1, JJ ), 1, $ WORK( MN+1 ), 1 ) DO 160 J = JJ+1, RANK+1 CALL ZCOPY( J, A( 1, J ), 1, $ A( 1, J-1 ), 1 ) 160 CONTINUE CALL ZCOPY( RANK+1, WORK( MN+1 ), 1, $ A( 1, RANK+1 ), 1 ) * * Exchange in the same way vector JPVT. * ITEMP = JPVT( JJ ) DO 170 J = JJ+1, RANK+1 JPVT( J-1 ) = JPVT( J ) 170 CONTINUE JPVT( RANK+1 ) = ITEMP * * Exchange in the same way vector RWORK. * TEMP = RWORK( JJ ) DO 180 J = JJ+1, RANK+1 RWORK( J-1 ) = RWORK( J ) 180 CONTINUE RWORK( RANK+1 ) = TEMP * * Retriangularize matrix A after the permutation. * IF( JOB.EQ.1 ) THEN CALL ZHESS( JOB, RANK-JJ+2, N-JJ+1, K, $ A( JJ, JJ ), LDA, CDUMMY, 1, $ WORK( MN+1 ), RWORK( N+1 ), INFO ) ELSE IF( JOB.EQ.2 ) THEN CALL ZHESS( JOB, RANK-JJ+2, N-JJ+1, K, $ A( JJ, JJ ), LDA, C( JJ, 1 ), LDC, $ WORK( MN+1 ), RWORK( N+1 ), INFO ) ELSE IF( JOB.EQ.3 ) THEN CALL ZHESS( JOB, RANK-JJ+2, N-JJ+1, K, $ A( JJ, JJ ), LDA, C( 1, JJ ), LDC, $ WORK( MN+1 ), RWORK( N+1 ), INFO ) END IF * * Estimate the smallest singular value of * A(1:RANK,1:RANK) and its corresponding left * singular vector. * SMIN will contain the smallest singular value and * WORK(1:MN) will contain the left singular * vector. * SMIN = ABS( A( 1, 1 ) ) WORK( 1 ) = CONE DO 190 J = 2, RANK CALL ZLAIC1( 2, J-1, WORK( 1 ), SMIN, $ A( 1, J ), A( J , J ), SMINPR, $ SINE, COSINE ) CALL ZSCAL( J-1, SINE, WORK( 1 ), 1 ) WORK( J ) = COSINE SMIN = SMINPR 190 CONTINUE END IF END IF * * Update loop variables. * NCA = 0 NS = NS+1 IF( II.EQ.N ) THEN II = RANK+1 ELSE II = II+1 END IF END IF GOTO 1000 END IF * * ********************* * * End of Loop WHILE * * ********************* * * ****************** * * Final Pivoting * * ****************** * * Exchange column in R(RANK+1:M,RANK+1:N) with largest norm to * position RANK+1. * JJ = RANK+IDAMAX( N-RANK, RWORK( RANK+1 ), 1 ) IF( ( JJ.GT.( RANK+1 ) ).AND. $ ( F*ABS( RWORK( JJ ) ).GT.ABS( RWORK( RANK+1 ) ) ) ) THEN * * Exchange column JJ to position RANK+1. * CALL ZCOPY( MIN( MN, JJ ), A( 1, JJ ), 1, $ WORK( MN+1 ), 1 ) DO 200 J = JJ-1, RANK+1, -1 CALL ZCOPY( MIN( MN, J+1 ), A( 1, J ), 1 , $ A( 1, J+1 ), 1 ) 200 CONTINUE CALL ZCOPY( MIN( MN, JJ ), WORK( MN+1 ), 1, $ A( 1, RANK+1 ), 1 ) * * Exchange in the same way vector JPVT. * ITEMP = JPVT( JJ ) DO 210 J = JJ-1, RANK+1, -1 JPVT( J+1 ) = JPVT( J ) 210 CONTINUE JPVT( RANK+1 ) = ITEMP * * Retriangularize matrix A after permutation. * IF( JOB.EQ.1 ) THEN CALL ZGRET( JOB, MIN( M, JJ )-RANK, N-RANK, K, $ A( RANK+1, RANK+1 ), LDA, CDUMMY, 1, $ WORK( MN+1 ), RWORK( N+1 ), INFO ) ELSE IF( JOB.EQ.2 ) THEN CALL ZGRET( JOB, MIN( M, JJ )-RANK, N-RANK, K, $ A( RANK+1, RANK+1 ), LDA, C( RANK+1, 1 ), $ LDC, WORK( MN+1 ), RWORK( N+1 ), INFO ) ELSE IF( JOB.EQ.3 ) THEN CALL ZGRET( JOB, MIN( M, JJ )-RANK, N-RANK, K, $ A( RANK+1, RANK+1 ), LDA, C( 1, RANK+1 ), $ LDC, WORK( MN+1 ), RWORK( N+1 ), INFO ) END IF END IF * * ************************************************************** * * Computation of vector SVLUES and variables RCNR and RCNRP1 * * ************************************************************** * * Computation of the largest singular value of A(1:RANK,1:RANK). * SMAX = ABS( A( 1, 1 ) ) WORK( MN+1 ) = CONE * DO 220 J = 2, RANK CALL ZLAIC1( 1, J-1, WORK( MN+1 ), SMAX, $ A( 1, J ), A( J, J ), SMAXPR, SINE, COSINE ) CALL ZSCAL( J-1, SINE, WORK( MN+1 ), 1 ) WORK( MN+J ) = COSINE SMAX = SMAXPR 220 CONTINUE SVLUES( IMAX ) = SMAX SVLUES( IBEFOR ) = SMIN * * Computation of the largest singular value and the smallest * singular value of A(1:RANK+1,1:RANK+1). * CALL ZLAIC1( 1, RANK, WORK( MN+1 ), SMAX, $ A( 1, RANK+1 ), A( RANK+1, RANK+1 ), SMXRP1, $ SINE, COSINE ) CALL ZLAIC1( 2, RANK, WORK( 1 ), SMIN, $ A( 1, RANK+1 ), A( RANK+1, RANK+1 ), SMINPR, $ SINE, COSINE ) CALL ZSCAL( RANK, SINE, WORK( 1 ), 1 ) WORK( RANK+1 ) = COSINE SMIN = SMINPR SVLUES( IAFTER ) = SMIN * * Computation of the smallest singular value of A(1:MN,1:MN). * DO 230 J = RANK+2, MN CALL ZLAIC1( 2, J-1, WORK( 1 ), SMIN, $ A( 1, J ), A( J, J ), SMINPR, SINE, COSINE ) CALL ZSCAL( J-1, SINE, WORK( 1 ), 1 ) WORK( J ) = COSINE SMIN = SMINPR 230 CONTINUE SVLUES( IMIN ) = SMIN * * Computation of RCNR and RCNRP1. * RCNR = SVLUES( IBEFOR ) / SVLUES( IMAX ) RCNRP1 = SVLUES( IAFTER ) / SMXRP1 * IF( NS.GE.MXSTPS ) THEN INFO = 1 END IF END IF RETURN * * End of ZTRQYC * END SHAR_EOF fi # end of overwriting check if test -f 'ztrrnk.f' then echo shar: will not over-write existing file "'ztrrnk.f'" else cat << SHAR_EOF > 'ztrrnk.f' SUBROUTINE ZTRRNK( N, R, LDR, RCOND, RANK, WORK, INFO ) * * $Revision: 1.42 $ * $Date: 96/12/30 16:59:45 $ * * .. Scalar Arguments .. INTEGER LDR, N, RANK, INFO DOUBLE PRECISION RCOND * .. * .. Array Arguments .. COMPLEX*16 R( LDR, * ), WORK( * ) * * Purpose * ======= * * ZTRRNK computes an estimate for the numerical rank of a * triangular n-by-n matrix R. * * Arguments * ========= * * N (input) INTEGER * Number of rows and columns of the matrix R. N >= 0. * * R (input) COMPLEX*16 array, dimension (LDR,N) * On entry, the n by n matrix R. * * LDR (input) INTEGER * The leading dimension of the array R. LDR >= max(1,N). * * RCOND (input) DOUBLE PRECISION * Threshold value for the numerical rank. * * RANK (output) INTEGER * Numerical rank for threshold RCOND. * * WORK (workspace) COMPLEX*16 array, dimension (2*N) * * INFO (output) INTEGER * = 0: Successful exit. * < 0: If INFO = -i, the i-th argument had an illegal value. * * ===================================================================== * * .. Parameters .. COMPLEX*16 CONE DOUBLE PRECISION ZERO PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ), ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I DOUBLE PRECISION SMAX, SMAXPR, SMIN, SMINPR COMPLEX*16 C1, C2, S1, S2 * .. * .. External Subroutines .. EXTERNAL ZLAIC1 * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. Executable statements .. * * Test the input arguments * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 ELSE IF( LDR.LT.MAX( 1, N ) ) THEN INFO = -3 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZTRRNK', -INFO ) RETURN END IF * * Determine RANK using incremental condition estimation. * WORK( 1 ) = CONE WORK( N+1 ) = CONE SMAX = ABS( R( 1, 1 ) ) SMIN = SMAX IF( ABS( R( 1, 1 ) ).EQ.ZERO ) THEN RANK = 0 GO TO 30 ELSE RANK = 1 END IF * 10 CONTINUE IF( RANK.LT.N ) THEN I = RANK + 1 CALL ZLAIC1( 2, RANK, WORK, SMIN, R( 1, I ), $ R( I, I ), SMINPR, S1, C1 ) CALL ZLAIC1( 1, RANK, WORK( N+1 ), SMAX, R( 1, I ), $ R( I, I ), SMAXPR, S2, C2 ) * IF( ( SMAXPR*RCOND ).LE.SMINPR ) THEN DO 20 I = 1, RANK WORK( I ) = S1*WORK( I ) WORK( N+I ) = S2*WORK( N+I ) 20 CONTINUE WORK( RANK+1 ) = C1 WORK( N+RANK+1 ) = C2 SMIN = SMINPR SMAX = SMAXPR RANK = RANK + 1 GO TO 10 END IF END IF 30 CONTINUE * RETURN * * End of ZTRRNK * END SHAR_EOF fi # end of overwriting check cd .. if test -f 'generate' then echo shar: will not over-write existing file "'generate'" else cat << SHAR_EOF > 'generate' #!/bin/csh -f # # Utility to run preprocessor and generate single, double, complex # and complex*16 versions of Fortran codes by using PREC_ and # FLOATING_DECLARE for real versions and CPREC_, RPREC_, # COMPLEX_DECLARE and REAL_DECLARE for complex versions. # if ($#argv < 4) goto usage set prec = $1 set infile = $2 set outfile = $3 set cpp = $4 if (($prec != "s")&&($prec != "d")&&($prec != "c")&&($prec != "z")) goto usage if (! -e $infile ) then echo "error in $0: cannot find $infile" exit 2 endif switch ( $prec ) case "s": $cpp -P -DSINGLE_REAL $argv[5-$#argv] $infile | \ sed -e 's/PREC_/S/g' \ -e 's/TOXREAL/REAL/g' \ -e 's/^ FLOATING_DECLARE/ REAL /g'\ -e 's/FLOATING_DECLARE/REAL/g'\ -e 's/GET_TIME/SECOND/g' \ -e '/^[ ]*$/d' \ > $outfile breaksw case "d": $cpp -P -DDOUBLE_REAL $argv[5-$#argv] $infile | \ sed -e 's/PREC_/D/g' \ -e 's/TOXREAL/DBLE/g' \ -e 's/^ FLOATING_DECLARE/ DOUBLE PRECISION/g'\ -e 's/FLOATING_DECLARE/DOUBLE PRECISION/g'\ -e 's/GET_TIME/DSECND/g' \ -e '/^[ ]*$/d' \ > $outfile breaksw case "c": $cpp -P -DSINGLE_COMPLEX $argv[5-$#argv] $infile | \ sed -e 's/RPREC_/S/g' \ -e 's/CPREC_/C/g' \ -e 's/TOXREAL/REAL/g' \ -e 's/^ REAL_DECLARE / REAL /g'\ -e 's/REAL_DECLARE/REAL/g'\ -e 's/^ COMPLEX_DECLARE / COMPLEX /g'\ -e 's/COMPLEX_DECLARE/COMPLEX/g'\ -e 's/GET_TIME/SECOND/g' \ -e '/^[ ]*$/d' \ > $outfile breaksw case "z": $cpp -P -DDOUBLE_COMPLEX $argv[5-$#argv] $infile | \ sed -e 's/RPREC_/D/g' \ -e 's/CPREC_/Z/g' \ -e 's/CONJG/DCONJG/g' \ -e 's/CMPLX/DCMPLX/g' \ -e 's/TOXREAL/DBLE/g' \ -e 's/^ REAL_DECLARE / DOUBLE PRECISION/g'\ -e 's/REAL_DECLARE/DOUBLE PRECISION/g'\ -e 's/^ COMPLEX_DECLARE / COMPLEX*16 /g'\ -e 's/COMPLEX_DECLARE/COMPLEX*16/g'\ -e 's/GET_TIME/DSECND/g' \ -e '/^[ ]*$/d' \ > $outfile breaksw endsw exit 0 usage: echo "$0 []" echo " = c or z" exit 1 SHAR_EOF fi # end of overwriting check if test ! -d 'lib' then mkdir 'lib' fi cd 'lib' if test -f 'Makefile' then echo shar: will not over-write existing file "'Makefile'" else cat << SHAR_EOF > 'Makefile' ####################################################################### # # The user must set this options: # FORTRAN = f77 OPTS = -u -g -C ARCH = ar ARCHFLAGS = cr RANLIB = ranlib # # On SUN computers, it is recommended: # #FORTRAN = f77 #OPTS = -u -O # # On IBM RS6K, it is recommended: # #FORTRAN = xlf #OPTS = -u -O3 # # ####################################################################### # No more changes are required beyond this line. ####################################################################### # # Other definitions: # REAL_SOURCES = ../v15.acm COMPLEX_SOURCES = ../cv15.acm RRQR_LIB = ../rrqr.a # ####################################################################### ####################################################################### # # Modules for Rank-Revealing QR: # S_RRQR_MODULES = \ sgeqpb.o sgeqpw.o sgeqpc.o \ sgeqpx.o strqpx.o strqxc.o \ sgeqpy.o strqpy.o strqyc.o \ strrnk.o slauc1.o slasmx.o \ smylap.o D_RRQR_MODULES = \ dgeqpb.o dgeqpw.o dgeqpc.o \ dgeqpx.o dtrqpx.o dtrqxc.o \ dgeqpy.o dtrqpy.o dtrqyc.o \ dtrrnk.o dlauc1.o dlasmx.o \ dmylap.o C_RRQR_MODULES = \ cgeqpb.o cgeqpw.o cgeqpc.o \ cgeqpx.o ctrqpx.o ctrqxc.o \ cgeqpy.o ctrqpy.o ctrqyc.o \ ctrrnk.o clauc1.o clasmx.o \ cmylap.o Z_RRQR_MODULES = \ zgeqpb.o zgeqpw.o zgeqpc.o \ zgeqpx.o ztrqpx.o ztrqxc.o \ zgeqpy.o ztrqpy.o ztrqyc.o \ ztrrnk.o zlauc1.o zlasmx.o \ zmylap.o # # ####################################################################### all: single double complex complex16 single: $(S_RRQR_MODULES) $(ARCH) $(ARCHFLAGS) $(RRQR_LIB) $(S_RRQR_MODULES) $(RANLIB) $(RRQR_LIB) double: $(D_RRQR_MODULES) $(ARCH) $(ARCHFLAGS) $(RRQR_LIB) $(D_RRQR_MODULES) $(RANLIB) $(RRQR_LIB) complex: $(C_RRQR_MODULES) $(ARCH) $(ARCHFLAGS) $(RRQR_LIB) $(C_RRQR_MODULES) $(RANLIB) $(RRQR_LIB) complex16: $(Z_RRQR_MODULES) $(ARCH) $(ARCHFLAGS) $(RRQR_LIB) $(Z_RRQR_MODULES) $(RANLIB) $(RRQR_LIB) clean: - rm -f *.o # # Rules for the object files of RRQR. # .f.o: # # Rules for the source modules of RRQR. # sgeqpb.o: $(REAL_SOURCES)/sgeqpb.f $(FORTRAN) -c $(OPTS) $? sgeqpw.o: $(REAL_SOURCES)/sgeqpw.f $(FORTRAN) -c $(OPTS) $? sgeqpc.o: $(REAL_SOURCES)/sgeqpc.f $(FORTRAN) -c $(OPTS) $? sgeqpx.o: $(REAL_SOURCES)/sgeqpx.f $(FORTRAN) -c $(OPTS) $? strqpx.o: $(REAL_SOURCES)/strqpx.f $(FORTRAN) -c $(OPTS) $? strqxc.o: $(REAL_SOURCES)/strqxc.f $(FORTRAN) -c $(OPTS) $? sgeqpy.o: $(REAL_SOURCES)/sgeqpy.f $(FORTRAN) -c $(OPTS) $? strqpy.o: $(REAL_SOURCES)/strqpy.f $(FORTRAN) -c $(OPTS) $? strqyc.o: $(REAL_SOURCES)/strqyc.f $(FORTRAN) -c $(OPTS) $? strrnk.o: $(REAL_SOURCES)/strrnk.f $(FORTRAN) -c $(OPTS) $? slauc1.o: $(REAL_SOURCES)/slauc1.f $(FORTRAN) -c $(OPTS) $? slasmx.o: $(REAL_SOURCES)/slasmx.f $(FORTRAN) -c $(OPTS) $? smylap.o: $(REAL_SOURCES)/smylap.f $(FORTRAN) -c $(OPTS) $? dgeqpb.o: $(REAL_SOURCES)/dgeqpb.f $(FORTRAN) -c $(OPTS) $? dgeqpw.o: $(REAL_SOURCES)/dgeqpw.f $(FORTRAN) -c $(OPTS) $? dgeqpc.o: $(REAL_SOURCES)/dgeqpc.f $(FORTRAN) -c $(OPTS) $? dgeqpx.o: $(REAL_SOURCES)/dgeqpx.f $(FORTRAN) -c $(OPTS) $? dtrqpx.o: $(REAL_SOURCES)/dtrqpx.f $(FORTRAN) -c $(OPTS) $? dtrqxc.o: $(REAL_SOURCES)/dtrqxc.f $(FORTRAN) -c $(OPTS) $? dgeqpy.o: $(REAL_SOURCES)/dgeqpy.f $(FORTRAN) -c $(OPTS) $? dtrqpy.o: $(REAL_SOURCES)/dtrqpy.f $(FORTRAN) -c $(OPTS) $? dtrqyc.o: $(REAL_SOURCES)/dtrqyc.f $(FORTRAN) -c $(OPTS) $? dtrrnk.o: $(REAL_SOURCES)/dtrrnk.f $(FORTRAN) -c $(OPTS) $? dlauc1.o: $(REAL_SOURCES)/dlauc1.f $(FORTRAN) -c $(OPTS) $? dlasmx.o: $(REAL_SOURCES)/dlasmx.f $(FORTRAN) -c $(OPTS) $? dmylap.o: $(REAL_SOURCES)/dmylap.f $(FORTRAN) -c $(OPTS) $? cgeqpb.o: $(COMPLEX_SOURCES)/cgeqpb.f $(FORTRAN) -c $(OPTS) $? cgeqpw.o: $(COMPLEX_SOURCES)/cgeqpw.f $(FORTRAN) -c $(OPTS) $? cgeqpc.o: $(COMPLEX_SOURCES)/cgeqpc.f $(FORTRAN) -c $(OPTS) $? cgeqpx.o: $(COMPLEX_SOURCES)/cgeqpx.f $(FORTRAN) -c $(OPTS) $? ctrqpx.o: $(COMPLEX_SOURCES)/ctrqpx.f $(FORTRAN) -c $(OPTS) $? ctrqxc.o: $(COMPLEX_SOURCES)/ctrqxc.f $(FORTRAN) -c $(OPTS) $? cgeqpy.o: $(COMPLEX_SOURCES)/cgeqpy.f $(FORTRAN) -c $(OPTS) $? ctrqpy.o: $(COMPLEX_SOURCES)/ctrqpy.f $(FORTRAN) -c $(OPTS) $? ctrqyc.o: $(COMPLEX_SOURCES)/ctrqyc.f $(FORTRAN) -c $(OPTS) $? ctrrnk.o: $(COMPLEX_SOURCES)/ctrrnk.f $(FORTRAN) -c $(OPTS) $? clauc1.o: $(COMPLEX_SOURCES)/clauc1.f $(FORTRAN) -c $(OPTS) $? clasmx.o: $(COMPLEX_SOURCES)/clasmx.f $(FORTRAN) -c $(OPTS) $? cmylap.o: $(COMPLEX_SOURCES)/cmylap.f $(FORTRAN) -c $(OPTS) $? zgeqpb.o: $(COMPLEX_SOURCES)/zgeqpb.f $(FORTRAN) -c $(OPTS) $? zgeqpw.o: $(COMPLEX_SOURCES)/zgeqpw.f $(FORTRAN) -c $(OPTS) $? zgeqpc.o: $(COMPLEX_SOURCES)/zgeqpc.f $(FORTRAN) -c $(OPTS) $? zgeqpx.o: $(COMPLEX_SOURCES)/zgeqpx.f $(FORTRAN) -c $(OPTS) $? ztrqpx.o: $(COMPLEX_SOURCES)/ztrqpx.f $(FORTRAN) -c $(OPTS) $? ztrqxc.o: $(COMPLEX_SOURCES)/ztrqxc.f $(FORTRAN) -c $(OPTS) $? zgeqpy.o: $(COMPLEX_SOURCES)/zgeqpy.f $(FORTRAN) -c $(OPTS) $? ztrqpy.o: $(COMPLEX_SOURCES)/ztrqpy.f $(FORTRAN) -c $(OPTS) $? ztrqyc.o: $(COMPLEX_SOURCES)/ztrqyc.f $(FORTRAN) -c $(OPTS) $? ztrrnk.o: $(COMPLEX_SOURCES)/ztrrnk.f $(FORTRAN) -c $(OPTS) $? zlauc1.o: $(COMPLEX_SOURCES)/zlauc1.f $(FORTRAN) -c $(OPTS) $? zlasmx.o: $(COMPLEX_SOURCES)/zlasmx.f $(FORTRAN) -c $(OPTS) $? zmylap.o: $(COMPLEX_SOURCES)/zmylap.f $(FORTRAN) -c $(OPTS) $? SHAR_EOF fi # end of overwriting check cd .. if test ! -d 'matgen' then mkdir 'matgen' fi cd 'matgen' if test -f 'Makefile' then echo shar: will not over-write existing file "'Makefile'" else cat << SHAR_EOF > 'Makefile' ####################################################################### # # Makefile for generating Matrix Generator of LAPACK 2.0 # ####################################################################### FORTRAN = f77 OPTS = -u -O -dalign ARCH = ar ARCHFLAGS = cr RANLIB = ranlib # ####################################################################### # No more changes are required beyond this line. ####################################################################### # ####################################################################### TMGLIB = ../tmglib.a SCATGEN = slatm1.o slaran.o slarnd.o SMATGEN = slatms.o slatme.o slatmr.o \ slagge.o slagsy.o slarge.o slaror.o slarot.o slatm2.o slatm3.o CMATGEN = clatms.o clatme.o clatmr.o \ clagge.o claghe.o clagsy.o clarge.o claror.o clarot.o clatm1.o \ clarnd.o clatm2.o clatm3.o DZATGEN = dlatm1.o dlaran.o dlarnd.o DMATGEN = dlatms.o dlatme.o dlatmr.o \ dlagge.o dlagsy.o dlarge.o dlaror.o dlarot.o dlatm2.o dlatm3.o ZMATGEN = zlatms.o zlatme.o zlatmr.o \ zlagge.o zlaghe.o zlagsy.o zlarge.o zlaror.o zlarot.o zlatm1.o \ zlarnd.o zlatm2.o zlatm3.o all: single complex double complex16 single: $(SMATGEN) $(SCATGEN) $(ARCH) $(ARCHFLAGS) $(TMGLIB) $(SMATGEN) $(SCATGEN) $(RANLIB) $(TMGLIB) complex: $(CMATGEN) $(SCATGEN) $(ARCH) $(ARCHFLAGS) $(TMGLIB) $(CMATGEN) $(SCATGEN) $(RANLIB) $(TMGLIB) double: $(DMATGEN) $(DZATGEN) $(ARCH) $(ARCHFLAGS) $(TMGLIB) $(DMATGEN) $(DZATGEN) $(RANLIB) $(TMGLIB) complex16: $(ZMATGEN) $(DZATGEN) $(ARCH) $(ARCHFLAGS) $(TMGLIB) $(ZMATGEN) $(DZATGEN) $(RANLIB) $(TMGLIB) $(SCATGEN): $(FRC) $(SMATGEN): $(FRC) $(CMATGEN): $(FRC) $(DZATGEN): $(FRC) $(DMATGEN): $(FRC) $(ZMATGEN): $(FRC) FRC: @FRC=$(FRC) clean: ; \ rm -f *.o .f.o: ; $(FORTRAN) -c $(OPTS) $< SHAR_EOF fi # end of overwriting check if test -f 'clagge.f' then echo shar: will not over-write existing file "'clagge.f'" else cat << SHAR_EOF > 'clagge.f' SUBROUTINE CLAGGE( M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO ) * * -- LAPACK auxiliary test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDA, M, N * .. * .. Array Arguments .. INTEGER ISEED( 4 ) REAL D( * ) COMPLEX A( LDA, * ), WORK( * ) * .. * * Purpose * ======= * * CLAGGE generates a complex general m by n matrix A, by pre- and post- * multiplying a real diagonal matrix D with random unitary matrices: * A = U*D*V. The lower and upper bandwidths may then be reduced to * kl and ku by additional unitary transformations. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * * KL (input) INTEGER * The number of nonzero subdiagonals within the band of A. * 0 <= KL <= M-1. * * KU (input) INTEGER * The number of nonzero superdiagonals within the band of A. * 0 <= KU <= N-1. * * D (input) REAL array, dimension (min(M,N)) * The diagonal elements of the diagonal matrix D. * * A (output) COMPLEX array, dimension (LDA,N) * The generated m by n matrix A. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= M. * * ISEED (input/output) INTEGER array, dimension (4) * On entry, the seed of the random number generator; the array * elements must be between 0 and 4095, and ISEED(4) must be * odd. * On exit, the seed is updated. * * WORK (workspace) COMPLEX array, dimension (M+N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. COMPLEX ZERO, ONE PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ), $ ONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. INTEGER I, J REAL WN COMPLEX TAU, WA, WB * .. * .. External Subroutines .. EXTERNAL CGEMV, CGERC, CLACGV, CLARNV, CSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, REAL * .. * .. External Functions .. REAL SCNRM2 EXTERNAL SCNRM2 * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( KL.LT.0 .OR. KL.GT.M-1 ) THEN INFO = -3 ELSE IF( KU.LT.0 .OR. KU.GT.N-1 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -7 END IF IF( INFO.LT.0 ) THEN CALL XERBLA( 'CLAGGE', -INFO ) RETURN END IF * * initialize A to diagonal matrix * DO 20 J = 1, N DO 10 I = 1, M A( I, J ) = ZERO 10 CONTINUE 20 CONTINUE DO 30 I = 1, MIN( M, N ) A( I, I ) = D( I ) 30 CONTINUE * * pre- and post-multiply A by random unitary matrices * DO 40 I = MIN( M, N ), 1, -1 IF( I.LT.M ) THEN * * generate random reflection * CALL CLARNV( 3, ISEED, M-I+1, WORK ) WN = SCNRM2( M-I+1, WORK, 1 ) WA = ( WN / ABS( WORK( 1 ) ) )*WORK( 1 ) IF( WN.EQ.ZERO ) THEN TAU = ZERO ELSE WB = WORK( 1 ) + WA CALL CSCAL( M-I, ONE / WB, WORK( 2 ), 1 ) WORK( 1 ) = ONE TAU = REAL( WB / WA ) END IF * * multiply A(i:m,i:n) by random reflection from the left * CALL CGEMV( 'Conjugate transpose', M-I+1, N-I+1, ONE, $ A( I, I ), LDA, WORK, 1, ZERO, WORK( M+1 ), 1 ) CALL CGERC( M-I+1, N-I+1, -TAU, WORK, 1, WORK( M+1 ), 1, $ A( I, I ), LDA ) END IF IF( I.LT.N ) THEN * * generate random reflection * CALL CLARNV( 3, ISEED, N-I+1, WORK ) WN = SCNRM2( N-I+1, WORK, 1 ) WA = ( WN / ABS( WORK( 1 ) ) )*WORK( 1 ) IF( WN.EQ.ZERO ) THEN TAU = ZERO ELSE WB = WORK( 1 ) + WA CALL CSCAL( N-I, ONE / WB, WORK( 2 ), 1 ) WORK( 1 ) = ONE TAU = REAL( WB / WA ) END IF * * multiply A(i:m,i:n) by random reflection from the right * CALL CGEMV( 'No transpose', M-I+1, N-I+1, ONE, A( I, I ), $ LDA, WORK, 1, ZERO, WORK( N+1 ), 1 ) CALL CGERC( M-I+1, N-I+1, -TAU, WORK( N+1 ), 1, WORK, 1, $ A( I, I ), LDA ) END IF 40 CONTINUE * * Reduce number of subdiagonals to KL and number of superdiagonals * to KU * DO 70 I = 1, MAX( M-1-KL, N-1-KU ) IF( KL.LE.KU ) THEN * * annihilate subdiagonal elements first (necessary if KL = 0) * IF( I.LE.MIN( M-1-KL, N ) ) THEN * * generate reflection to annihilate A(kl+i+1:m,i) * WN = SCNRM2( M-KL-I+1, A( KL+I, I ), 1 ) WA = ( WN / ABS( A( KL+I, I ) ) )*A( KL+I, I ) IF( WN.EQ.ZERO ) THEN TAU = ZERO ELSE WB = A( KL+I, I ) + WA CALL CSCAL( M-KL-I, ONE / WB, A( KL+I+1, I ), 1 ) A( KL+I, I ) = ONE TAU = REAL( WB / WA ) END IF * * apply reflection to A(kl+i:m,i+1:n) from the left * CALL CGEMV( 'Conjugate transpose', M-KL-I+1, N-I, ONE, $ A( KL+I, I+1 ), LDA, A( KL+I, I ), 1, ZERO, $ WORK, 1 ) CALL CGERC( M-KL-I+1, N-I, -TAU, A( KL+I, I ), 1, WORK, $ 1, A( KL+I, I+1 ), LDA ) A( KL+I, I ) = -WA END IF * IF( I.LE.MIN( N-1-KU, M ) ) THEN * * generate reflection to annihilate A(i,ku+i+1:n) * WN = SCNRM2( N-KU-I+1, A( I, KU+I ), LDA ) WA = ( WN / ABS( A( I, KU+I ) ) )*A( I, KU+I ) IF( WN.EQ.ZERO ) THEN TAU = ZERO ELSE WB = A( I, KU+I ) + WA CALL CSCAL( N-KU-I, ONE / WB, A( I, KU+I+1 ), LDA ) A( I, KU+I ) = ONE TAU = REAL( WB / WA ) END IF * * apply reflection to A(i+1:m,ku+i:n) from the right * CALL CLACGV( N-KU-I+1, A( I, KU+I ), LDA ) CALL CGEMV( 'No transpose', M-I, N-KU-I+1, ONE, $ A( I+1, KU+I ), LDA, A( I, KU+I ), LDA, ZERO, $ WORK, 1 ) CALL CGERC( M-I, N-KU-I+1, -TAU, WORK, 1, A( I, KU+I ), $ LDA, A( I+1, KU+I ), LDA ) A( I, KU+I ) = -WA END IF ELSE * * annihilate superdiagonal elements first (necessary if * KU = 0) * IF( I.LE.MIN( N-1-KU, M ) ) THEN * * generate reflection to annihilate A(i,ku+i+1:n) * WN = SCNRM2( N-KU-I+1, A( I, KU+I ), LDA ) WA = ( WN / ABS( A( I, KU+I ) ) )*A( I, KU+I ) IF( WN.EQ.ZERO ) THEN TAU = ZERO ELSE WB = A( I, KU+I ) + WA CALL CSCAL( N-KU-I, ONE / WB, A( I, KU+I+1 ), LDA ) A( I, KU+I ) = ONE TAU = REAL( WB / WA ) END IF * * apply reflection to A(i+1:m,ku+i:n) from the right * CALL CLACGV( N-KU-I+1, A( I, KU+I ), LDA ) CALL CGEMV( 'No transpose', M-I, N-KU-I+1, ONE, $ A( I+1, KU+I ), LDA, A( I, KU+I ), LDA, ZERO, $ WORK, 1 ) CALL CGERC( M-I, N-KU-I+1, -TAU, WORK, 1, A( I, KU+I ), $ LDA, A( I+1, KU+I ), LDA ) A( I, KU+I ) = -WA END IF * IF( I.LE.MIN( M-1-KL, N ) ) THEN * * generate reflection to annihilate A(kl+i+1:m,i) * WN = SCNRM2( M-KL-I+1, A( KL+I, I ), 1 ) WA = ( WN / ABS( A( KL+I, I ) ) )*A( KL+I, I ) IF( WN.EQ.ZERO ) THEN TAU = ZERO ELSE WB = A( KL+I, I ) + WA CALL CSCAL( M-KL-I, ONE / WB, A( KL+I+1, I ), 1 ) A( KL+I, I ) = ONE TAU = REAL( WB / WA ) END IF * * apply reflection to A(kl+i:m,i+1:n) from the left * CALL CGEMV( 'Conjugate transpose', M-KL-I+1, N-I, ONE, $ A( KL+I, I+1 ), LDA, A( KL+I, I ), 1, ZERO, $ WORK, 1 ) CALL CGERC( M-KL-I+1, N-I, -TAU, A( KL+I, I ), 1, WORK, $ 1, A( KL+I, I+1 ), LDA ) A( KL+I, I ) = -WA END IF END IF * DO 50 J = KL + I + 1, M A( J, I ) = ZERO 50 CONTINUE * DO 60 J = KU + I + 1, N A( I, J ) = ZERO 60 CONTINUE 70 CONTINUE RETURN * * End of CLAGGE * END SHAR_EOF fi # end of overwriting check if test -f 'claghe.f' then echo shar: will not over-write existing file "'claghe.f'" else cat << SHAR_EOF > 'claghe.f' SUBROUTINE CLAGHE( N, K, D, A, LDA, ISEED, WORK, INFO ) * * -- LAPACK auxiliary test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, N * .. * .. Array Arguments .. INTEGER ISEED( 4 ) REAL D( * ) COMPLEX A( LDA, * ), WORK( * ) * .. * * Purpose * ======= * * CLAGHE generates a complex hermitian matrix A, by pre- and post- * multiplying a real diagonal matrix D with a random unitary matrix: * A = U*D*U'. The semi-bandwidth may then be reduced to k by additional * unitary transformations. * * Arguments * ========= * * N (input) INTEGER * The order of the matrix A. N >= 0. * * K (input) INTEGER * The number of nonzero subdiagonals within the band of A. * 0 <= K <= N-1. * * D (input) REAL array, dimension (N) * The diagonal elements of the diagonal matrix D. * * A (output) COMPLEX array, dimension (LDA,N) * The generated n by n hermitian matrix A (the full matrix is * stored). * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= N. * * ISEED (input/output) INTEGER array, dimension (4) * On entry, the seed of the random number generator; the array * elements must be between 0 and 4095, and ISEED(4) must be * odd. * On exit, the seed is updated. * * WORK (workspace) COMPLEX array, dimension (2*N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. COMPLEX ZERO, ONE, HALF PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ), $ ONE = ( 1.0E+0, 0.0E+0 ), $ HALF = ( 0.5E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. INTEGER I, J REAL WN COMPLEX ALPHA, TAU, WA, WB * .. * .. External Subroutines .. EXTERNAL CAXPY, CGEMV, CGERC, CHEMV, CHER2, CLARNV, $ CSCAL, XERBLA * .. * .. External Functions .. REAL SCNRM2 COMPLEX CDOTC EXTERNAL SCNRM2, CDOTC * .. * .. Intrinsic Functions .. INTRINSIC ABS, CONJG, MAX, REAL * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 ELSE IF( K.LT.0 .OR. K.GT.N-1 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 END IF IF( INFO.LT.0 ) THEN CALL XERBLA( 'CLAGHE', -INFO ) RETURN END IF * * initialize lower triangle of A to diagonal matrix * DO 20 J = 1, N DO 10 I = J + 1, N A( I, J ) = ZERO 10 CONTINUE 20 CONTINUE DO 30 I = 1, N A( I, I ) = D( I ) 30 CONTINUE * * Generate lower triangle of hermitian matrix * DO 40 I = N - 1, 1, -1 * * generate random reflection * CALL CLARNV( 3, ISEED, N-I+1, WORK ) WN = SCNRM2( N-I+1, WORK, 1 ) WA = ( WN / ABS( WORK( 1 ) ) )*WORK( 1 ) IF( WN.EQ.ZERO ) THEN TAU = ZERO ELSE WB = WORK( 1 ) + WA CALL CSCAL( N-I, ONE / WB, WORK( 2 ), 1 ) WORK( 1 ) = ONE TAU = REAL( WB / WA ) END IF * * apply random reflection to A(i:n,i:n) from the left * and the right * * compute y := tau * A * u * CALL CHEMV( 'Lower', N-I+1, TAU, A( I, I ), LDA, WORK, 1, ZERO, $ WORK( N+1 ), 1 ) * * compute v := y - 1/2 * tau * ( y, u ) * u * ALPHA = -HALF*TAU*CDOTC( N-I+1, WORK( N+1 ), 1, WORK, 1 ) CALL CAXPY( N-I+1, ALPHA, WORK, 1, WORK( N+1 ), 1 ) * * apply the transformation as a rank-2 update to A(i:n,i:n) * CALL CHER2( 'Lower', N-I+1, -ONE, WORK, 1, WORK( N+1 ), 1, $ A( I, I ), LDA ) 40 CONTINUE * * Reduce number of subdiagonals to K * DO 60 I = 1, N - 1 - K * * generate reflection to annihilate A(k+i+1:n,i) * WN = SCNRM2( N-K-I+1, A( K+I, I ), 1 ) WA = ( WN / ABS( A( K+I, I ) ) )*A( K+I, I ) IF( WN.EQ.ZERO ) THEN TAU = ZERO ELSE WB = A( K+I, I ) + WA CALL CSCAL( N-K-I, ONE / WB, A( K+I+1, I ), 1 ) A( K+I, I ) = ONE TAU = REAL( WB / WA ) END IF * * apply reflection to A(k+i:n,i+1:k+i-1) from the left * CALL CGEMV( 'Conjugate transpose', N-K-I+1, K-1, ONE, $ A( K+I, I+1 ), LDA, A( K+I, I ), 1, ZERO, WORK, 1 ) CALL CGERC( N-K-I+1, K-1, -TAU, A( K+I, I ), 1, WORK, 1, $ A( K+I, I+1 ), LDA ) * * apply reflection to A(k+i:n,k+i:n) from the left and the right * * compute y := tau * A * u * CALL CHEMV( 'Lower', N-K-I+1, TAU, A( K+I, K+I ), LDA, $ A( K+I, I ), 1, ZERO, WORK, 1 ) * * compute v := y - 1/2 * tau * ( y, u ) * u * ALPHA = -HALF*TAU*CDOTC( N-K-I+1, WORK, 1, A( K+I, I ), 1 ) CALL CAXPY( N-K-I+1, ALPHA, A( K+I, I ), 1, WORK, 1 ) * * apply hermitian rank-2 update to A(k+i:n,k+i:n) * CALL CHER2( 'Lower', N-K-I+1, -ONE, A( K+I, I ), 1, WORK, 1, $ A( K+I, K+I ), LDA ) * A( K+I, I ) = -WA DO 50 J = K + I + 1, N A( J, I ) = ZERO 50 CONTINUE 60 CONTINUE * * Store full hermitian matrix * DO 80 J = 1, N DO 70 I = J + 1, N A( J, I ) = CONJG( A( I, J ) ) 70 CONTINUE 80 CONTINUE RETURN * * End of CLAGHE * END SHAR_EOF fi # end of overwriting check if test -f 'clagsy.f' then echo shar: will not over-write existing file "'clagsy.f'" else cat << SHAR_EOF > 'clagsy.f' SUBROUTINE CLAGSY( N, K, D, A, LDA, ISEED, WORK, INFO ) * * -- LAPACK auxiliary test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, N * .. * .. Array Arguments .. INTEGER ISEED( 4 ) REAL D( * ) COMPLEX A( LDA, * ), WORK( * ) * .. * * Purpose * ======= * * CLAGSY generates a complex symmetric matrix A, by pre- and post- * multiplying a real diagonal matrix D with a random unitary matrix: * A = U*D*U**T. The semi-bandwidth may then be reduced to k by * additional unitary transformations. * * Arguments * ========= * * N (input) INTEGER * The order of the matrix A. N >= 0. * * K (input) INTEGER * The number of nonzero subdiagonals within the band of A. * 0 <= K <= N-1. * * D (input) REAL array, dimension (N) * The diagonal elements of the diagonal matrix D. * * A (output) COMPLEX array, dimension (LDA,N) * The generated n by n symmetric matrix A (the full matrix is * stored). * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= N. * * ISEED (input/output) INTEGER array, dimension (4) * On entry, the seed of the random number generator; the array * elements must be between 0 and 4095, and ISEED(4) must be * odd. * On exit, the seed is updated. * * WORK (workspace) COMPLEX array, dimension (2*N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. COMPLEX ZERO, ONE, HALF PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ), $ ONE = ( 1.0E+0, 0.0E+0 ), $ HALF = ( 0.5E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. INTEGER I, II, J, JJ REAL WN COMPLEX ALPHA, TAU, WA, WB * .. * .. External Subroutines .. EXTERNAL CAXPY, CGEMV, CGERC, CLACGV, CLARNV, CSCAL, $ CSYMV, XERBLA * .. * .. External Functions .. REAL SCNRM2 COMPLEX CDOTC EXTERNAL SCNRM2, CDOTC * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, REAL * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 ELSE IF( K.LT.0 .OR. K.GT.N-1 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 END IF IF( INFO.LT.0 ) THEN CALL XERBLA( 'CLAGSY', -INFO ) RETURN END IF * * initialize lower triangle of A to diagonal matrix * DO 20 J = 1, N DO 10 I = J + 1, N A( I, J ) = ZERO 10 CONTINUE 20 CONTINUE DO 30 I = 1, N A( I, I ) = D( I ) 30 CONTINUE * * Generate lower triangle of symmetric matrix * DO 60 I = N - 1, 1, -1 * * generate random reflection * CALL CLARNV( 3, ISEED, N-I+1, WORK ) WN = SCNRM2( N-I+1, WORK, 1 ) WA = ( WN / ABS( WORK( 1 ) ) )*WORK( 1 ) IF( WN.EQ.ZERO ) THEN TAU = ZERO ELSE WB = WORK( 1 ) + WA CALL CSCAL( N-I, ONE / WB, WORK( 2 ), 1 ) WORK( 1 ) = ONE TAU = REAL( WB / WA ) END IF * * apply random reflection to A(i:n,i:n) from the left * and the right * * compute y := tau * A * conjg(u) * CALL CLACGV( N-I+1, WORK, 1 ) CALL CSYMV( 'Lower', N-I+1, TAU, A( I, I ), LDA, WORK, 1, ZERO, $ WORK( N+1 ), 1 ) CALL CLACGV( N-I+1, WORK, 1 ) * * compute v := y - 1/2 * tau * ( u, y ) * u * ALPHA = -HALF*TAU*CDOTC( N-I+1, WORK, 1, WORK( N+1 ), 1 ) CALL CAXPY( N-I+1, ALPHA, WORK, 1, WORK( N+1 ), 1 ) * * apply the transformation as a rank-2 update to A(i:n,i:n) * * CALL CSYR2( 'Lower', N-I+1, -ONE, WORK, 1, WORK( N+1 ), 1, * $ A( I, I ), LDA ) * DO 50 JJ = I, N DO 40 II = JJ, N A( II, JJ ) = A( II, JJ ) - $ WORK( II-I+1 )*WORK( N+JJ-I+1 ) - $ WORK( N+II-I+1 )*WORK( JJ-I+1 ) 40 CONTINUE 50 CONTINUE 60 CONTINUE * * Reduce number of subdiagonals to K * DO 100 I = 1, N - 1 - K * * generate reflection to annihilate A(k+i+1:n,i) * WN = SCNRM2( N-K-I+1, A( K+I, I ), 1 ) WA = ( WN / ABS( A( K+I, I ) ) )*A( K+I, I ) IF( WN.EQ.ZERO ) THEN TAU = ZERO ELSE WB = A( K+I, I ) + WA CALL CSCAL( N-K-I, ONE / WB, A( K+I+1, I ), 1 ) A( K+I, I ) = ONE TAU = REAL( WB / WA ) END IF * * apply reflection to A(k+i:n,i+1:k+i-1) from the left * CALL CGEMV( 'Conjugate transpose', N-K-I+1, K-1, ONE, $ A( K+I, I+1 ), LDA, A( K+I, I ), 1, ZERO, WORK, 1 ) CALL CGERC( N-K-I+1, K-1, -TAU, A( K+I, I ), 1, WORK, 1, $ A( K+I, I+1 ), LDA ) * * apply reflection to A(k+i:n,k+i:n) from the left and the right * * compute y := tau * A * conjg(u) * CALL CLACGV( N-K-I+1, A( K+I, I ), 1 ) CALL CSYMV( 'Lower', N-K-I+1, TAU, A( K+I, K+I ), LDA, $ A( K+I, I ), 1, ZERO, WORK, 1 ) CALL CLACGV( N-K-I+1, A( K+I, I ), 1 ) * * compute v := y - 1/2 * tau * ( u, y ) * u * ALPHA = -HALF*TAU*CDOTC( N-K-I+1, A( K+I, I ), 1, WORK, 1 ) CALL CAXPY( N-K-I+1, ALPHA, A( K+I, I ), 1, WORK, 1 ) * * apply symmetric rank-2 update to A(k+i:n,k+i:n) * * CALL CSYR2( 'Lower', N-K-I+1, -ONE, A( K+I, I ), 1, WORK, 1, * $ A( K+I, K+I ), LDA ) * DO 80 JJ = K + I, N DO 70 II = JJ, N A( II, JJ ) = A( II, JJ ) - A( II, I )*WORK( JJ-K-I+1 ) - $ WORK( II-K-I+1 )*A( JJ, I ) 70 CONTINUE 80 CONTINUE * A( K+I, I ) = -WA DO 90 J = K + I + 1, N A( J, I ) = ZERO 90 CONTINUE 100 CONTINUE * * Store full symmetric matrix * DO 120 J = 1, N DO 110 I = J + 1, N A( J, I ) = A( I, J ) 110 CONTINUE 120 CONTINUE RETURN * * End of CLAGSY * END SHAR_EOF fi # end of overwriting check if test -f 'clarge.f' then echo shar: will not over-write existing file "'clarge.f'" else cat << SHAR_EOF > 'clarge.f' SUBROUTINE CLARGE( N, A, LDA, ISEED, WORK, INFO ) * * -- LAPACK auxiliary test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. INTEGER INFO, LDA, N * .. * .. Array Arguments .. INTEGER ISEED( 4 ) COMPLEX A( LDA, * ), WORK( * ) * .. * * Purpose * ======= * * CLARGE pre- and post-multiplies a complex general n by n matrix A * with a random unitary matrix: A = U*D*U'. * * Arguments * ========= * * N (input) INTEGER * The order of the matrix A. N >= 0. * * A (input/output) COMPLEX array, dimension (LDA,N) * On entry, the original n by n matrix A. * On exit, A is overwritten by U*A*U' for some random * unitary matrix U. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= N. * * ISEED (input/output) INTEGER array, dimension (4) * On entry, the seed of the random number generator; the array * elements must be between 0 and 4095, and ISEED(4) must be * odd. * On exit, the seed is updated. * * WORK (workspace) COMPLEX array, dimension (2*N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. COMPLEX ZERO, ONE PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ), $ ONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. INTEGER I REAL WN COMPLEX TAU, WA, WB * .. * .. External Subroutines .. EXTERNAL CGEMV, CGERC, CLARNV, CSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, REAL * .. * .. External Functions .. REAL SCNRM2 EXTERNAL SCNRM2 * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -3 END IF IF( INFO.LT.0 ) THEN CALL XERBLA( 'CLARGE', -INFO ) RETURN END IF * * pre- and post-multiply A by random unitary matrix * DO 10 I = N, 1, -1 * * generate random reflection * CALL CLARNV( 3, ISEED, N-I+1, WORK ) WN = SCNRM2( N-I+1, WORK, 1 ) WA = ( WN / ABS( WORK( 1 ) ) )*WORK( 1 ) IF( WN.EQ.ZERO ) THEN TAU = ZERO ELSE WB = WORK( 1 ) + WA CALL CSCAL( N-I, ONE / WB, WORK( 2 ), 1 ) WORK( 1 ) = ONE TAU = REAL( WB / WA ) END IF * * multiply A(i:n,1:n) by random reflection from the left * CALL CGEMV( 'Conjugate transpose', N-I+1, N, ONE, A( I, 1 ), $ LDA, WORK, 1, ZERO, WORK( N+1 ), 1 ) CALL CGERC( N-I+1, N, -TAU, WORK, 1, WORK( N+1 ), 1, A( I, 1 ), $ LDA ) * * multiply A(1:n,i:n) by random reflection from the right * CALL CGEMV( 'No transpose', N, N-I+1, ONE, A( 1, I ), LDA, $ WORK, 1, ZERO, WORK( N+1 ), 1 ) CALL CGERC( N, N-I+1, -TAU, WORK( N+1 ), 1, WORK, 1, A( 1, I ), $ LDA ) 10 CONTINUE RETURN * * End of CLARGE * END SHAR_EOF fi # end of overwriting check if test -f 'clarnd.f' then echo shar: will not over-write existing file "'clarnd.f'" else cat << SHAR_EOF > 'clarnd.f' COMPLEX FUNCTION CLARND( IDIST, ISEED ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. INTEGER IDIST * .. * .. Array Arguments .. INTEGER ISEED( 4 ) * .. * * Purpose * ======= * * CLARND returns a random complex number from a uniform or normal * distribution. * * Arguments * ========= * * IDIST (input) INTEGER * Specifies the distribution of the random numbers: * = 1: real and imaginary parts each uniform (0,1) * = 2: real and imaginary parts each uniform (-1,1) * = 3: real and imaginary parts each normal (0,1) * = 4: uniformly distributed on the disc abs(z) <= 1 * = 5: uniformly distributed on the circle abs(z) = 1 * * ISEED (input/output) INTEGER array, dimension (4) * On entry, the seed of the random number generator; the array * elements must be between 0 and 4095, and ISEED(4) must be * odd. * On exit, the seed is updated. * * Further Details * =============== * * This routine calls the auxiliary routine SLARAN to generate a random * real number from a uniform (0,1) distribution. The Box-Muller method * is used to transform numbers from a uniform to a normal distribution. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE, TWO PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 ) REAL TWOPI PARAMETER ( TWOPI = 6.2831853071795864769252867663E+0 ) * .. * .. Local Scalars .. REAL T1, T2 * .. * .. External Functions .. REAL SLARAN EXTERNAL SLARAN * .. * .. Intrinsic Functions .. INTRINSIC CMPLX, EXP, LOG, SQRT * .. * .. Executable Statements .. * * Generate a pair of real random numbers from a uniform (0,1) * distribution * T1 = SLARAN( ISEED ) T2 = SLARAN( ISEED ) * IF( IDIST.EQ.1 ) THEN * * real and imaginary parts each uniform (0,1) * CLARND = CMPLX( T1, T2 ) ELSE IF( IDIST.EQ.2 ) THEN * * real and imaginary parts each uniform (-1,1) * CLARND = CMPLX( TWO*T1-ONE, TWO*T2-ONE ) ELSE IF( IDIST.EQ.3 ) THEN * * real and imaginary parts each normal (0,1) * CLARND = SQRT( -TWO*LOG( T1 ) )*EXP( CMPLX( ZERO, TWOPI*T2 ) ) ELSE IF( IDIST.EQ.4 ) THEN * * uniform distribution on the unit disc abs(z) <= 1 * CLARND = SQRT( T1 )*EXP( CMPLX( ZERO, TWOPI*T2 ) ) ELSE IF( IDIST.EQ.5 ) THEN * * uniform distribution on the unit circle abs(z) = 1 * CLARND = EXP( CMPLX( ZERO, TWOPI*T2 ) ) END IF RETURN * * End of CLARND * END SHAR_EOF fi # end of overwriting check if test -f 'claror.f' then echo shar: will not over-write existing file "'claror.f'" else cat << SHAR_EOF > 'claror.f' SUBROUTINE CLAROR( SIDE, INIT, M, N, A, LDA, ISEED, X, INFO ) * * -- LAPACK auxiliary test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER INIT, SIDE INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. INTEGER ISEED( 4 ) COMPLEX A( LDA, * ), X( * ) * .. * * Purpose * ======= * * CLAROR pre- or post-multiplies an M by N matrix A by a random * unitary matrix U, overwriting A. A may optionally be * initialized to the identity matrix before multiplying by U. * U is generated using the method of G.W. Stewart * ( SIAM J. Numer. Anal. 17, 1980, pp. 403-409 ). * (BLAS-2 version) * * Arguments * ========= * * SIDE - CHARACTER*1 * SIDE specifies whether A is multiplied on the left or right * by U. * SIDE = 'L' Multiply A on the left (premultiply) by U * SIDE = 'R' Multiply A on the right (postmultiply) by U* * SIDE = 'C' Multiply A on the left by U and the right by U* * SIDE = 'T' Multiply A on the left by U and the right by U' * Not modified. * * INIT - CHARACTER*1 * INIT specifies whether or not A should be initialized to * the identity matrix. * INIT = 'I' Initialize A to (a section of) the * identity matrix before applying U. * INIT = 'N' No initialization. Apply U to the * input matrix A. * * INIT = 'I' may be used to generate square (i.e., unitary) * or rectangular orthogonal matrices (orthogonality being * in the sense of CDOTC): * * For square matrices, M=N, and SIDE many be either 'L' or * 'R'; the rows will be orthogonal to each other, as will the * columns. * For rectangular matrices where M < N, SIDE = 'R' will * produce a dense matrix whose rows will be orthogonal and * whose columns will not, while SIDE = 'L' will produce a * matrix whose rows will be orthogonal, and whose first M * columns will be orthogonal, the remaining columns being * zero. * For matrices where M > N, just use the previous * explaination, interchanging 'L' and 'R' and "rows" and * "columns". * * Not modified. * * M - INTEGER * Number of rows of A. Not modified. * * N - INTEGER * Number of columns of A. Not modified. * * A - COMPLEX array, dimension ( LDA, N ) * Input and output array. Overwritten by U A ( if SIDE = 'L' ) * or by A U ( if SIDE = 'R' ) * or by U A U* ( if SIDE = 'C') * or by U A U' ( if SIDE = 'T') on exit. * * LDA - INTEGER * Leading dimension of A. Must be at least MAX ( 1, M ). * Not modified. * * ISEED - INTEGER array, dimension ( 4 ) * On entry ISEED specifies the seed of the random number * generator. The array elements should be between 0 and 4095; * if not they will be reduced mod 4096. Also, ISEED(4) must * be odd. The random number generator uses a linear * congruential sequence limited to small integers, and so * should produce machine independent random numbers. The * values of ISEED are changed on exit, and can be used in the * next call to CLAROR to continue the same random number * sequence. * Modified. * * X - COMPLEX array, dimension ( 3*MAX( M, N ) ) * Workspace. Of length: * 2*M + N if SIDE = 'L', * 2*N + M if SIDE = 'R', * 3*N if SIDE = 'C' or 'T'. * Modified. * * INFO - INTEGER * An error flag. It is set to: * 0 if no error. * 1 if CLARND returned a bad random number (installation * problem) * -1 if SIDE is not L, R, C, or T. * -3 if M is negative. * -4 if N is negative or if SIDE is C or T and N is not equal * to M. * -6 if LDA is less than M. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE, TOOSML PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, $ TOOSML = 1.0E-20 ) COMPLEX CZERO, CONE PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ), $ CONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. INTEGER IROW, ITYPE, IXFRM, J, JCOL, KBEG, NXFRM REAL FACTOR, XABS, XNORM COMPLEX CSIGN, XNORMS * .. * .. External Functions .. LOGICAL LSAME REAL SCNRM2 COMPLEX CLARND EXTERNAL LSAME, SCNRM2, CLARND * .. * .. External Subroutines .. EXTERNAL CGEMV, CGERC, CLACGV, CLASET, CSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, CMPLX, CONJG * .. * .. Executable Statements .. * IF( N.EQ.0 .OR. M.EQ.0 ) $ RETURN * ITYPE = 0 IF( LSAME( SIDE, 'L' ) ) THEN ITYPE = 1 ELSE IF( LSAME( SIDE, 'R' ) ) THEN ITYPE = 2 ELSE IF( LSAME( SIDE, 'C' ) ) THEN ITYPE = 3 ELSE IF( LSAME( SIDE, 'T' ) ) THEN ITYPE = 4 END IF * * Check for argument errors. * INFO = 0 IF( ITYPE.EQ.0 ) THEN INFO = -1 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.3 .AND. N.NE.M ) ) THEN INFO = -4 ELSE IF( LDA.LT.M ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CLAROR', -INFO ) RETURN END IF * IF( ITYPE.EQ.1 ) THEN NXFRM = M ELSE NXFRM = N END IF * * Initialize A to the identity matrix if desired * IF( LSAME( INIT, 'I' ) ) $ CALL CLASET( 'Full', M, N, CZERO, CONE, A, LDA ) * * If no rotation possible, still multiply by * a random complex number from the circle |x| = 1 * * 2) Compute Rotation by computing Householder * Transformations H(2), H(3), ..., H(n). Note that the * order in which they are computed is irrelevant. * DO 40 J = 1, NXFRM X( J ) = CZERO 40 CONTINUE * DO 60 IXFRM = 2, NXFRM KBEG = NXFRM - IXFRM + 1 * * Generate independent normal( 0, 1 ) random numbers * DO 50 J = KBEG, NXFRM X( J ) = CLARND( 3, ISEED ) 50 CONTINUE * * Generate a Householder transformation from the random vector X * XNORM = SCNRM2( IXFRM, X( KBEG ), 1 ) XABS = ABS( X( KBEG ) ) IF( XABS.NE.CZERO ) THEN CSIGN = X( KBEG ) / XABS ELSE CSIGN = CONE END IF XNORMS = CSIGN*XNORM X( NXFRM+KBEG ) = -CSIGN FACTOR = XNORM*( XNORM+XABS ) IF( ABS( FACTOR ).LT.TOOSML ) THEN INFO = 1 CALL XERBLA( 'CLAROR', -INFO ) RETURN ELSE FACTOR = ONE / FACTOR END IF X( KBEG ) = X( KBEG ) + XNORMS * * Apply Householder transformation to A * IF( ITYPE.EQ.1 .OR. ITYPE.EQ.3 .OR. ITYPE.EQ.4 ) THEN * * Apply H(k) on the left of A * CALL CGEMV( 'C', IXFRM, N, CONE, A( KBEG, 1 ), LDA, $ X( KBEG ), 1, CZERO, X( 2*NXFRM+1 ), 1 ) CALL CGERC( IXFRM, N, -CMPLX( FACTOR ), X( KBEG ), 1, $ X( 2*NXFRM+1 ), 1, A( KBEG, 1 ), LDA ) * END IF * IF( ITYPE.GE.2 .AND. ITYPE.LE.4 ) THEN * * Apply H(k)* (or H(k)') on the right of A * IF( ITYPE.EQ.4 ) THEN CALL CLACGV( IXFRM, X( KBEG ), 1 ) END IF * CALL CGEMV( 'N', M, IXFRM, CONE, A( 1, KBEG ), LDA, $ X( KBEG ), 1, CZERO, X( 2*NXFRM+1 ), 1 ) CALL CGERC( M, IXFRM, -CMPLX( FACTOR ), X( 2*NXFRM+1 ), 1, $ X( KBEG ), 1, A( 1, KBEG ), LDA ) * END IF 60 CONTINUE * X( 1 ) = CLARND( 3, ISEED ) XABS = ABS( X( 1 ) ) IF( XABS.NE.ZERO ) THEN CSIGN = X( 1 ) / XABS ELSE CSIGN = CONE END IF X( 2*NXFRM ) = CSIGN * * Scale the matrix A by D. * IF( ITYPE.EQ.1 .OR. ITYPE.EQ.3 .OR. ITYPE.EQ.4 ) THEN DO 70 IROW = 1, M CALL CSCAL( N, CONJG( X( NXFRM+IROW ) ), A( IROW, 1 ), LDA ) 70 CONTINUE END IF * IF( ITYPE.EQ.2 .OR. ITYPE.EQ.3 ) THEN DO 80 JCOL = 1, N CALL CSCAL( M, X( NXFRM+JCOL ), A( 1, JCOL ), 1 ) 80 CONTINUE END IF * IF( ITYPE.EQ.4 ) THEN DO 90 JCOL = 1, N CALL CSCAL( M, CONJG( X( NXFRM+JCOL ) ), A( 1, JCOL ), 1 ) 90 CONTINUE END IF RETURN * * End of CLAROR * END SHAR_EOF fi # end of overwriting check if test -f 'clarot.f' then echo shar: will not over-write existing file "'clarot.f'" else cat << SHAR_EOF > 'clarot.f' SUBROUTINE CLAROT( LROWS, LLEFT, LRIGHT, NL, C, S, A, LDA, XLEFT, $ XRIGHT ) * * -- LAPACK auxiliary test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. LOGICAL LLEFT, LRIGHT, LROWS INTEGER LDA, NL COMPLEX C, S, XLEFT, XRIGHT * .. * .. Array Arguments .. COMPLEX A( * ) * .. * * Purpose * ======= * * CLAROT applies a (Givens) rotation to two adjacent rows or * columns, where one element of the first and/or last column/row * may be a separate variable. This is specifically indended * for use on matrices stored in some format other than GE, so * that elements of the matrix may be used or modified for which * no array element is provided. * * One example is a symmetric matrix in SB format (bandwidth=4), for * which UPLO='L': Two adjacent rows will have the format: * * row j: * * * * * . . . . * row j+1: * * * * * . . . . * * '*' indicates elements for which storage is provided, * '.' indicates elements for which no storage is provided, but * are not necessarily zero; their values are determined by * symmetry. ' ' indicates elements which are necessarily zero, * and have no storage provided. * * Those columns which have two '*'s can be handled by SROT. * Those columns which have no '*'s can be ignored, since as long * as the Givens rotations are carefully applied to preserve * symmetry, their values are determined. * Those columns which have one '*' have to be handled separately, * by using separate variables "p" and "q": * * row j: * * * * * p . . . * row j+1: q * * * * * . . . . * * The element p would have to be set correctly, then that column * is rotated, setting p to its new value. The next call to * CLAROT would rotate columns j and j+1, using p, and restore * symmetry. The element q would start out being zero, and be * made non-zero by the rotation. Later, rotations would presumably * be chosen to zero q out. * * Typical Calling Sequences: rotating the i-th and (i+1)-st rows. * ------- ------- --------- * * General dense matrix: * * CALL CLAROT(.TRUE.,.FALSE.,.FALSE., N, C,S, * A(i,1),LDA, DUMMY, DUMMY) * * General banded matrix in GB format: * * j = MAX(1, i-KL ) * NL = MIN( N, i+KU+1 ) + 1-j * CALL CLAROT( .TRUE., i-KL.GE.1, i+KU.LT.N, NL, C,S, * A(KU+i+1-j,j),LDA-1, XLEFT, XRIGHT ) * * [ note that i+1-j is just MIN(i,KL+1) ] * * Symmetric banded matrix in SY format, bandwidth K, * lower triangle only: * * j = MAX(1, i-K ) * NL = MIN( K+1, i ) + 1 * CALL CLAROT( .TRUE., i-K.GE.1, .TRUE., NL, C,S, * A(i,j), LDA, XLEFT, XRIGHT ) * * Same, but upper triangle only: * * NL = MIN( K+1, N-i ) + 1 * CALL CLAROT( .TRUE., .TRUE., i+K.LT.N, NL, C,S, * A(i,i), LDA, XLEFT, XRIGHT ) * * Symmetric banded matrix in SB format, bandwidth K, * lower triangle only: * * [ same as for SY, except:] * . . . . * A(i+1-j,j), LDA-1, XLEFT, XRIGHT ) * * [ note that i+1-j is just MIN(i,K+1) ] * * Same, but upper triangle only: * . . . * A(K+1,i), LDA-1, XLEFT, XRIGHT ) * * Rotating columns is just the transpose of rotating rows, except * for GB and SB: (rotating columns i and i+1) * * GB: * j = MAX(1, i-KU ) * NL = MIN( N, i+KL+1 ) + 1-j * CALL CLAROT( .TRUE., i-KU.GE.1, i+KL.LT.N, NL, C,S, * A(KU+j+1-i,i),LDA-1, XTOP, XBOTTM ) * * [note that KU+j+1-i is just MAX(1,KU+2-i)] * * SB: (upper triangle) * * . . . . . . * A(K+j+1-i,i),LDA-1, XTOP, XBOTTM ) * * SB: (lower triangle) * * . . . . . . * A(1,i),LDA-1, XTOP, XBOTTM ) * * Arguments * ========= * * LROWS - LOGICAL * If .TRUE., then CLAROT will rotate two rows. If .FALSE., * then it will rotate two columns. * Not modified. * * LLEFT - LOGICAL * If .TRUE., then XLEFT will be used instead of the * corresponding element of A for the first element in the * second row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) * If .FALSE., then the corresponding element of A will be * used. * Not modified. * * LRIGHT - LOGICAL * If .TRUE., then XRIGHT will be used instead of the * corresponding element of A for the last element in the * first row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) If * .FALSE., then the corresponding element of A will be used. * Not modified. * * NL - INTEGER * The length of the rows (if LROWS=.TRUE.) or columns (if * LROWS=.FALSE.) to be rotated. If XLEFT and/or XRIGHT are * used, the columns/rows they are in should be included in * NL, e.g., if LLEFT = LRIGHT = .TRUE., then NL must be at * least 2. The number of rows/columns to be rotated * exclusive of those involving XLEFT and/or XRIGHT may * not be negative, i.e., NL minus how many of LLEFT and * LRIGHT are .TRUE. must be at least zero; if not, XERBLA * will be called. * Not modified. * * C, S - COMPLEX * Specify the Givens rotation to be applied. If LROWS is * true, then the matrix ( c s ) * ( _ _ ) * (-s c ) is applied from the left; * if false, then the transpose (not conjugated) thereof is * applied from the right. Note that in contrast to the * output of CROTG or to most versions of CROT, both C and S * are complex. For a Givens rotation, |C|**2 + |S|**2 should * be 1, but this is not checked. * Not modified. * * A - COMPLEX array. * The array containing the rows/columns to be rotated. The * first element of A should be the upper left element to * be rotated. * Read and modified. * * LDA - INTEGER * The "effective" leading dimension of A. If A contains * a matrix stored in GE, HE, or SY format, then this is just * the leading dimension of A as dimensioned in the calling * routine. If A contains a matrix stored in band (GB, HB, or * SB) format, then this should be *one less* than the leading * dimension used in the calling routine. Thus, if A were * dimensioned A(LDA,*) in CLAROT, then A(1,j) would be the * j-th element in the first of the two rows to be rotated, * and A(2,j) would be the j-th in the second, regardless of * how the array may be stored in the calling routine. [A * cannot, however, actually be dimensioned thus, since for * band format, the row number may exceed LDA, which is not * legal FORTRAN.] * If LROWS=.TRUE., then LDA must be at least 1, otherwise * it must be at least NL minus the number of .TRUE. values * in XLEFT and XRIGHT. * Not modified. * * XLEFT - COMPLEX * If LLEFT is .TRUE., then XLEFT will be used and modified * instead of A(2,1) (if LROWS=.TRUE.) or A(1,2) * (if LROWS=.FALSE.). * Read and modified. * * XRIGHT - COMPLEX * If LRIGHT is .TRUE., then XRIGHT will be used and modified * instead of A(1,NL) (if LROWS=.TRUE.) or A(NL,1) * (if LROWS=.FALSE.). * Read and modified. * * ===================================================================== * * .. Local Scalars .. INTEGER IINC, INEXT, IX, IY, IYT, J, NT COMPLEX TEMPX * .. * .. Local Arrays .. COMPLEX XT( 2 ), YT( 2 ) * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CONJG * .. * .. Executable Statements .. * * Set up indices, arrays for ends * IF( LROWS ) THEN IINC = LDA INEXT = 1 ELSE IINC = 1 INEXT = LDA END IF * IF( LLEFT ) THEN NT = 1 IX = 1 + IINC IY = 2 + LDA XT( 1 ) = A( 1 ) YT( 1 ) = XLEFT ELSE NT = 0 IX = 1 IY = 1 + INEXT END IF * IF( LRIGHT ) THEN IYT = 1 + INEXT + ( NL-1 )*IINC NT = NT + 1 XT( NT ) = XRIGHT YT( NT ) = A( IYT ) END IF * * Check for errors * IF( NL.LT.NT ) THEN CALL XERBLA( 'CLAROT', 4 ) RETURN END IF IF( LDA.LE.0 .OR. ( .NOT.LROWS .AND. LDA.LT.NL-NT ) ) THEN CALL XERBLA( 'CLAROT', 8 ) RETURN END IF * * Rotate * * CROT( NL-NT, A(IX),IINC, A(IY),IINC, C, S ) with complex C, S * DO 10 J = 0, NL - NT - 1 TEMPX = C*A( IX+J*IINC ) + S*A( IY+J*IINC ) A( IY+J*IINC ) = -CONJG( S )*A( IX+J*IINC ) + $ CONJG( C )*A( IY+J*IINC ) A( IX+J*IINC ) = TEMPX 10 CONTINUE * * CROT( NT, XT,1, YT,1, C, S ) with complex C, S * DO 20 J = 1, NT TEMPX = C*XT( J ) + S*YT( J ) YT( J ) = -CONJG( S )*XT( J ) + CONJG( C )*YT( J ) XT( J ) = TEMPX 20 CONTINUE * * Stuff values back into XLEFT, XRIGHT, etc. * IF( LLEFT ) THEN A( 1 ) = XT( 1 ) XLEFT = YT( 1 ) END IF * IF( LRIGHT ) THEN XRIGHT = XT( NT ) A( IYT ) = YT( NT ) END IF * RETURN * * End of CLAROT * END SHAR_EOF fi # end of overwriting check if test -f 'clatm1.f' then echo shar: will not over-write existing file "'clatm1.f'" else cat << SHAR_EOF > 'clatm1.f' SUBROUTINE CLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO ) * * -- LAPACK auxiliary test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. INTEGER IDIST, INFO, IRSIGN, MODE, N REAL COND * .. * .. Array Arguments .. INTEGER ISEED( 4 ) COMPLEX D( * ) * .. * * Purpose * ======= * * CLATM1 computes the entries of D(1..N) as specified by * MODE, COND and IRSIGN. IDIST and ISEED determine the generation * of random numbers. CLATM1 is called by CLATMR to generate * random test matrices for LAPACK programs. * * Arguments * ========= * * MODE - INTEGER * On entry describes how D is to be computed: * MODE = 0 means do not change D. * MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND * MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND * MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) * MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) * MODE = 5 sets D to random numbers in the range * ( 1/COND , 1 ) such that their logarithms * are uniformly distributed. * MODE = 6 set D to random numbers from same distribution * as the rest of the matrix. * MODE < 0 has the same meaning as ABS(MODE), except that * the order of the elements of D is reversed. * Thus if MODE is positive, D has entries ranging from * 1 to 1/COND, if negative, from 1/COND to 1, * Not modified. * * COND - REAL * On entry, used as described under MODE above. * If used, it must be >= 1. Not modified. * * IRSIGN - INTEGER * On entry, if MODE neither -6, 0 nor 6, determines sign of * entries of D * 0 => leave entries of D unchanged * 1 => multiply each entry of D by random complex number * uniformly distributed with absolute value 1 * * IDIST - CHARACTER*1 * On entry, IDIST specifies the type of distribution to be * used to generate a random matrix . * 1 => real and imaginary parts each UNIFORM( 0, 1 ) * 2 => real and imaginary parts each UNIFORM( -1, 1 ) * 3 => real and imaginary parts each NORMAL( 0, 1 ) * 4 => complex number uniform in DISK( 0, 1 ) * Not modified. * * ISEED - INTEGER array, dimension ( 4 ) * On entry ISEED specifies the seed of the random number * generator. The random number generator uses a * linear congruential sequence limited to small * integers, and so should produce machine independent * random numbers. The values of ISEED are changed on * exit, and can be used in the next call to CLATM1 * to continue the same random number sequence. * Changed on exit. * * D - COMPLEX array, dimension ( MIN( M , N ) ) * Array to be computed according to MODE, COND and IRSIGN. * May be changed on exit if MODE is nonzero. * * N - INTEGER * Number of entries of D. Not modified. * * INFO - INTEGER * 0 => normal termination * -1 => if MODE not in range -6 to 6 * -2 => if MODE neither -6, 0 nor 6, and * IRSIGN neither 0 nor 1 * -3 => if MODE neither -6, 0 nor 6 and COND less than 1 * -4 => if MODE equals 6 or -6 and IDIST not in range 1 to 4 * -7 => if N negative * * ===================================================================== * * .. Parameters .. REAL ONE PARAMETER ( ONE = 1.0E0 ) * .. * .. Local Scalars .. INTEGER I REAL ALPHA, TEMP COMPLEX CTEMP * .. * .. External Functions .. REAL SLARAN COMPLEX CLARND EXTERNAL SLARAN, CLARND * .. * .. External Subroutines .. EXTERNAL CLARNV, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, EXP, LOG, REAL * .. * .. Executable Statements .. * * Decode and Test the input parameters. Initialize flags & seed. * INFO = 0 * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Set INFO if an error * IF( MODE.LT.-6 .OR. MODE.GT.6 ) THEN INFO = -1 ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND. $ ( IRSIGN.NE.0 .AND. IRSIGN.NE.1 ) ) THEN INFO = -2 ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND. $ COND.LT.ONE ) THEN INFO = -3 ELSE IF( ( MODE.EQ.6 .OR. MODE.EQ.-6 ) .AND. $ ( IDIST.LT.1 .OR. IDIST.GT.4 ) ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -7 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'CLATM1', -INFO ) RETURN END IF * * Compute D according to COND and MODE * IF( MODE.NE.0 ) THEN GO TO ( 10, 30, 50, 70, 90, 110 )ABS( MODE ) * * One large D value: * 10 CONTINUE DO 20 I = 1, N D( I ) = ONE / COND 20 CONTINUE D( 1 ) = ONE GO TO 120 * * One small D value: * 30 CONTINUE DO 40 I = 1, N D( I ) = ONE 40 CONTINUE D( N ) = ONE / COND GO TO 120 * * Exponentially distributed D values: * 50 CONTINUE D( 1 ) = ONE IF( N.GT.1 ) THEN ALPHA = COND**( -ONE / REAL( N-1 ) ) DO 60 I = 2, N D( I ) = ALPHA**( I-1 ) 60 CONTINUE END IF GO TO 120 * * Arithmetically distributed D values: * 70 CONTINUE D( 1 ) = ONE IF( N.GT.1 ) THEN TEMP = ONE / COND ALPHA = ( ONE-TEMP ) / REAL( N-1 ) DO 80 I = 2, N D( I ) = REAL( N-I )*ALPHA + TEMP 80 CONTINUE END IF GO TO 120 * * Randomly distributed D values on ( 1/COND , 1): * 90 CONTINUE ALPHA = LOG( ONE / COND ) DO 100 I = 1, N D( I ) = EXP( ALPHA*SLARAN( ISEED ) ) 100 CONTINUE GO TO 120 * * Randomly distributed D values from IDIST * 110 CONTINUE CALL CLARNV( IDIST, ISEED, N, D ) * 120 CONTINUE * * If MODE neither -6 nor 0 nor 6, and IRSIGN = 1, assign * random signs to D * IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND. $ IRSIGN.EQ.1 ) THEN DO 130 I = 1, N CTEMP = CLARND( 3, ISEED ) D( I ) = D( I )*( CTEMP / ABS( CTEMP ) ) 130 CONTINUE END IF * * Reverse if MODE < 0 * IF( MODE.LT.0 ) THEN DO 140 I = 1, N / 2 CTEMP = D( I ) D( I ) = D( N+1-I ) D( N+1-I ) = CTEMP 140 CONTINUE END IF * END IF * RETURN * * End of CLATM1 * END SHAR_EOF fi # end of overwriting check if test -f 'clatm2.f' then echo shar: will not over-write existing file "'clatm2.f'" else cat << SHAR_EOF > 'clatm2.f' COMPLEX FUNCTION CLATM2( M, N, I, J, KL, KU, IDIST, ISEED, D, $ IGRADE, DL, DR, IPVTNG, IWORK, SPARSE ) * * -- LAPACK auxiliary test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. * INTEGER I, IDIST, IGRADE, IPVTNG, J, KL, KU, M, N REAL SPARSE * .. * * .. Array Arguments .. * INTEGER ISEED( 4 ), IWORK( * ) COMPLEX D( * ), DL( * ), DR( * ) * .. * * Purpose * ======= * * CLATM2 returns the (I,J) entry of a random matrix of dimension * (M, N) described by the other paramters. It is called by the * CLATMR routine in order to build random test matrices. No error * checking on parameters is done, because this routine is called in * a tight loop by CLATMR which has already checked the parameters. * * Use of CLATM2 differs from CLATM3 in the order in which the random * number generator is called to fill in random matrix entries. * With CLATM2, the generator is called to fill in the pivoted matrix * columnwise. With CLATM3, the generator is called to fill in the * matrix columnwise, after which it is pivoted. Thus, CLATM3 can * be used to construct random matrices which differ only in their * order of rows and/or columns. CLATM2 is used to construct band * matrices while avoiding calling the random number generator for * entries outside the band (and therefore generating random numbers * * The matrix whose (I,J) entry is returned is constructed as * follows (this routine only computes one entry): * * If I is outside (1..M) or J is outside (1..N), return zero * (this is convenient for generating matrices in band format). * * Generate a matrix A with random entries of distribution IDIST. * * Set the diagonal to D. * * Grade the matrix, if desired, from the left (by DL) and/or * from the right (by DR or DL) as specified by IGRADE. * * Permute, if desired, the rows and/or columns as specified by * IPVTNG and IWORK. * * Band the matrix to have lower bandwidth KL and upper * bandwidth KU. * * Set random entries to zero as specified by SPARSE. * * Arguments * ========= * * M - INTEGER * Number of rows of matrix. Not modified. * * N - INTEGER * Number of columns of matrix. Not modified. * * I - INTEGER * Row of entry to be returned. Not modified. * * J - INTEGER * Column of entry to be returned. Not modified. * * KL - INTEGER * Lower bandwidth. Not modified. * * KU - INTEGER * Upper bandwidth. Not modified. * * IDIST - INTEGER * On entry, IDIST specifies the type of distribution to be * used to generate a random matrix . * 1 => real and imaginary parts each UNIFORM( 0, 1 ) * 2 => real and imaginary parts each UNIFORM( -1, 1 ) * 3 => real and imaginary parts each NORMAL( 0, 1 ) * 4 => complex number uniform in DISK( 0 , 1 ) * Not modified. * * ISEED - INTEGER array of dimension ( 4 ) * Seed for random number generator. * Changed on exit. * * D - COMPLEX array of dimension ( MIN( I , J ) ) * Diagonal entries of matrix. Not modified. * * IGRADE - INTEGER * Specifies grading of matrix as follows: * 0 => no grading * 1 => matrix premultiplied by diag( DL ) * 2 => matrix postmultiplied by diag( DR ) * 3 => matrix premultiplied by diag( DL ) and * postmultiplied by diag( DR ) * 4 => matrix premultiplied by diag( DL ) and * postmultiplied by inv( diag( DL ) ) * 5 => matrix premultiplied by diag( DL ) and * postmultiplied by diag( CONJG(DL) ) * 6 => matrix premultiplied by diag( DL ) and * postmultiplied by diag( DL ) * Not modified. * * DL - COMPLEX array ( I or J, as appropriate ) * Left scale factors for grading matrix. Not modified. * * DR - COMPLEX array ( I or J, as appropriate ) * Right scale factors for grading matrix. Not modified. * * IPVTNG - INTEGER * On entry specifies pivoting permutations as follows: * 0 => none. * 1 => row pivoting. * 2 => column pivoting. * 3 => full pivoting, i.e., on both sides. * Not modified. * * IWORK - INTEGER array ( I or J, as appropriate ) * This array specifies the permutation used. The * row (or column) in position K was originally in * position IWORK( K ). * This differs from IWORK for CLATM3. Not modified. * * SPARSE - REAL between 0. and 1. * On entry specifies the sparsity of the matrix * if sparse matix is to be generated. * SPARSE should lie between 0 and 1. * A uniform ( 0, 1 ) random number x is generated and * compared to SPARSE; if x is larger the matrix entry * is unchanged and if x is smaller the entry is set * to zero. Thus on the average a fraction SPARSE of the * entries will be set to zero. * Not modified. * * ===================================================================== * * .. Parameters .. * COMPLEX CZERO PARAMETER ( CZERO = ( 0.0E0, 0.0E0 ) ) REAL ZERO PARAMETER ( ZERO = 0.0E0 ) * .. * * .. Local Scalars .. * INTEGER ISUB, JSUB COMPLEX CTEMP * .. * * .. External Functions .. * REAL SLARAN COMPLEX CLARND EXTERNAL SLARAN, CLARND * .. * * .. Intrinsic Functions .. * INTRINSIC CONJG * .. * *----------------------------------------------------------------------- * * .. Executable Statements .. * * * Check for I and J in range * IF( I.LT.1 .OR. I.GT.M .OR. J.LT.1 .OR. J.GT.N ) THEN CLATM2 = CZERO RETURN END IF * * Check for banding * IF( J.GT.I+KU .OR. J.LT.I-KL ) THEN CLATM2 = CZERO RETURN END IF * * Check for sparsity * IF( SPARSE.GT.ZERO ) THEN IF( SLARAN( ISEED ).LT.SPARSE ) THEN CLATM2 = CZERO RETURN END IF END IF * * Compute subscripts depending on IPVTNG * IF( IPVTNG.EQ.0 ) THEN ISUB = I JSUB = J ELSE IF( IPVTNG.EQ.1 ) THEN ISUB = IWORK( I ) JSUB = J ELSE IF( IPVTNG.EQ.2 ) THEN ISUB = I JSUB = IWORK( J ) ELSE IF( IPVTNG.EQ.3 ) THEN ISUB = IWORK( I ) JSUB = IWORK( J ) END IF * * Compute entry and grade it according to IGRADE * IF( ISUB.EQ.JSUB ) THEN CTEMP = D( ISUB ) ELSE CTEMP = CLARND( IDIST, ISEED ) END IF IF( IGRADE.EQ.1 ) THEN CTEMP = CTEMP*DL( ISUB ) ELSE IF( IGRADE.EQ.2 ) THEN CTEMP = CTEMP*DR( JSUB ) ELSE IF( IGRADE.EQ.3 ) THEN CTEMP = CTEMP*DL( ISUB )*DR( JSUB ) ELSE IF( IGRADE.EQ.4 .AND. ISUB.NE.JSUB ) THEN CTEMP = CTEMP*DL( ISUB ) / DL( JSUB ) ELSE IF( IGRADE.EQ.5 ) THEN CTEMP = CTEMP*DL( ISUB )*CONJG( DL( JSUB ) ) ELSE IF( IGRADE.EQ.6 ) THEN CTEMP = CTEMP*DL( ISUB )*DL( JSUB ) END IF CLATM2 = CTEMP RETURN * * End of CLATM2 * END SHAR_EOF fi # end of overwriting check if test -f 'clatm3.f' then echo shar: will not over-write existing file "'clatm3.f'" else cat << SHAR_EOF > 'clatm3.f' COMPLEX FUNCTION CLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, $ SPARSE ) * * -- LAPACK auxiliary test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. * INTEGER I, IDIST, IGRADE, IPVTNG, ISUB, J, JSUB, KL, $ KU, M, N REAL SPARSE * .. * * .. Array Arguments .. * INTEGER ISEED( 4 ), IWORK( * ) COMPLEX D( * ), DL( * ), DR( * ) * .. * * Purpose * ======= * * CLATM3 returns the (ISUB,JSUB) entry of a random matrix of * dimension (M, N) described by the other paramters. (ISUB,JSUB) * is the final position of the (I,J) entry after pivoting * according to IPVTNG and IWORK. CLATM3 is called by the * CLATMR routine in order to build random test matrices. No error * checking on parameters is done, because this routine is called in * a tight loop by CLATMR which has already checked the parameters. * * Use of CLATM3 differs from CLATM2 in the order in which the random * number generator is called to fill in random matrix entries. * With CLATM2, the generator is called to fill in the pivoted matrix * columnwise. With CLATM3, the generator is called to fill in the * matrix columnwise, after which it is pivoted. Thus, CLATM3 can * be used to construct random matrices which differ only in their * order of rows and/or columns. CLATM2 is used to construct band * matrices while avoiding calling the random number generator for * entries outside the band (and therefore generating random numbers * in different orders for different pivot orders). * * The matrix whose (ISUB,JSUB) entry is returned is constructed as * follows (this routine only computes one entry): * * If ISUB is outside (1..M) or JSUB is outside (1..N), return zero * (this is convenient for generating matrices in band format). * * Generate a matrix A with random entries of distribution IDIST. * * Set the diagonal to D. * * Grade the matrix, if desired, from the left (by DL) and/or * from the right (by DR or DL) as specified by IGRADE. * * Permute, if desired, the rows and/or columns as specified by * IPVTNG and IWORK. * * Band the matrix to have lower bandwidth KL and upper * bandwidth KU. * * Set random entries to zero as specified by SPARSE. * * Arguments * ========= * * M - INTEGER * Number of rows of matrix. Not modified. * * N - INTEGER * Number of columns of matrix. Not modified. * * I - INTEGER * Row of unpivoted entry to be returned. Not modified. * * J - INTEGER * Column of unpivoted entry to be returned. Not modified. * * ISUB - INTEGER * Row of pivoted entry to be returned. Changed on exit. * * JSUB - INTEGER * Column of pivoted entry to be returned. Changed on exit. * * KL - INTEGER * Lower bandwidth. Not modified. * * KU - INTEGER * Upper bandwidth. Not modified. * * IDIST - INTEGER * On entry, IDIST specifies the type of distribution to be * used to generate a random matrix . * 1 => real and imaginary parts each UNIFORM( 0, 1 ) * 2 => real and imaginary parts each UNIFORM( -1, 1 ) * 3 => real and imaginary parts each NORMAL( 0, 1 ) * 4 => complex number uniform in DISK( 0 , 1 ) * Not modified. * * ISEED - INTEGER array of dimension ( 4 ) * Seed for random number generator. * Changed on exit. * * D - COMPLEX array of dimension ( MIN( I , J ) ) * Diagonal entries of matrix. Not modified. * * IGRADE - INTEGER * Specifies grading of matrix as follows: * 0 => no grading * 1 => matrix premultiplied by diag( DL ) * 2 => matrix postmultiplied by diag( DR ) * 3 => matrix premultiplied by diag( DL ) and * postmultiplied by diag( DR ) * 4 => matrix premultiplied by diag( DL ) and * postmultiplied by inv( diag( DL ) ) * 5 => matrix premultiplied by diag( DL ) and * postmultiplied by diag( CONJG(DL) ) * 6 => matrix premultiplied by diag( DL ) and * postmultiplied by diag( DL ) * Not modified. * * DL - COMPLEX array ( I or J, as appropriate ) * Left scale factors for grading matrix. Not modified. * * DR - COMPLEX array ( I or J, as appropriate ) * Right scale factors for grading matrix. Not modified. * * IPVTNG - INTEGER * On entry specifies pivoting permutations as follows: * 0 => none. * 1 => row pivoting. * 2 => column pivoting. * 3 => full pivoting, i.e., on both sides. * Not modified. * * IWORK - INTEGER array ( I or J, as appropriate ) * This array specifies the permutation used. The * row (or column) originally in position K is in * position IWORK( K ) after pivoting. * This differs from IWORK for CLATM2. Not modified. * * SPARSE - REAL between 0. and 1. * On entry specifies the sparsity of the matrix * if sparse matix is to be generated. * SPARSE should lie between 0 and 1. * A uniform ( 0, 1 ) random number x is generated and * compared to SPARSE; if x is larger the matrix entry * is unchanged and if x is smaller the entry is set * to zero. Thus on the average a fraction SPARSE of the * entries will be set to zero. * Not modified. * * ===================================================================== * * .. Parameters .. * REAL ZERO PARAMETER ( ZERO = 0.0E0 ) COMPLEX CZERO PARAMETER ( CZERO = ( 0.0E0, 0.0E0 ) ) * .. * * .. Local Scalars .. * COMPLEX CTEMP * .. * * .. External Functions .. * REAL SLARAN COMPLEX CLARND EXTERNAL SLARAN, CLARND * .. * * .. Intrinsic Functions .. * INTRINSIC CONJG * .. * *----------------------------------------------------------------------- * * .. Executable Statements .. * * * Check for I and J in range * IF( I.LT.1 .OR. I.GT.M .OR. J.LT.1 .OR. J.GT.N ) THEN ISUB = I JSUB = J CLATM3 = CZERO RETURN END IF * * Compute subscripts depending on IPVTNG * IF( IPVTNG.EQ.0 ) THEN ISUB = I JSUB = J ELSE IF( IPVTNG.EQ.1 ) THEN ISUB = IWORK( I ) JSUB = J ELSE IF( IPVTNG.EQ.2 ) THEN ISUB = I JSUB = IWORK( J ) ELSE IF( IPVTNG.EQ.3 ) THEN ISUB = IWORK( I ) JSUB = IWORK( J ) END IF * * Check for banding * IF( JSUB.GT.ISUB+KU .OR. JSUB.LT.ISUB-KL ) THEN CLATM3 = CZERO RETURN END IF * * Check for sparsity * IF( SPARSE.GT.ZERO ) THEN IF( SLARAN( ISEED ).LT.SPARSE ) THEN CLATM3 = CZERO RETURN END IF END IF * * Compute entry and grade it according to IGRADE * IF( I.EQ.J ) THEN CTEMP = D( I ) ELSE CTEMP = CLARND( IDIST, ISEED ) END IF IF( IGRADE.EQ.1 ) THEN CTEMP = CTEMP*DL( I ) ELSE IF( IGRADE.EQ.2 ) THEN CTEMP = CTEMP*DR( J ) ELSE IF( IGRADE.EQ.3 ) THEN CTEMP = CTEMP*DL( I )*DR( J ) ELSE IF( IGRADE.EQ.4 .AND. I.NE.J ) THEN CTEMP = CTEMP*DL( I ) / DL( J ) ELSE IF( IGRADE.EQ.5 ) THEN CTEMP = CTEMP*DL( I )*CONJG( DL( J ) ) ELSE IF( IGRADE.EQ.6 ) THEN CTEMP = CTEMP*DL( I )*DL( J ) END IF CLATM3 = CTEMP RETURN * * End of CLATM3 * END SHAR_EOF fi # end of overwriting check if test -f 'clatme.f' then echo shar: will not over-write existing file "'clatme.f'" else cat << SHAR_EOF > 'clatme.f' SUBROUTINE CLATME( N, DIST, ISEED, D, MODE, COND, DMAX, EI, RSIGN, $ UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, A, $ LDA, WORK, INFO ) * * -- LAPACK test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER DIST, EI, RSIGN, SIM, UPPER INTEGER INFO, KL, KU, LDA, MODE, MODES, N REAL ANORM, COND, CONDS COMPLEX DMAX * .. * .. Array Arguments .. INTEGER ISEED( 4 ) REAL DS( * ) COMPLEX A( LDA, * ), D( * ), WORK( * ) * .. * * Purpose * ======= * * CLATME generates random non-symmetric square matrices with * specified eigenvalues for testing LAPACK programs. * * CLATME operates by applying the following sequence of * operations: * * 1. Set the diagonal to D, where D may be input or * computed according to MODE, COND, DMAX, and RSIGN * as described below. * * 2. If UPPER='T', the upper triangle of A is set to random values * out of distribution DIST. * * 3. If SIM='T', A is multiplied on the left by a random matrix * X, whose singular values are specified by DS, MODES, and * CONDS, and on the right by X inverse. * * 4. If KL < N-1, the lower bandwidth is reduced to KL using * Householder transformations. If KU < N-1, the upper * bandwidth is reduced to KU. * * 5. If ANORM is not negative, the matrix is scaled to have * maximum-element-norm ANORM. * * (Note: since the matrix cannot be reduced beyond Hessenberg form, * no packing options are available.) * * Arguments * ========= * * N - INTEGER * The number of columns (or rows) of A. Not modified. * * DIST - CHARACTER*1 * On entry, DIST specifies the type of distribution to be used * to generate the random eigen-/singular values, and on the * upper triangle (see UPPER). * 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) * 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) * 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) * 'D' => uniform on the complex disc |z| < 1. * Not modified. * * ISEED - INTEGER array, dimension ( 4 ) * On entry ISEED specifies the seed of the random number * generator. They should lie between 0 and 4095 inclusive, * and ISEED(4) should be odd. The random number generator * uses a linear congruential sequence limited to small * integers, and so should produce machine independent * random numbers. The values of ISEED are changed on * exit, and can be used in the next call to CLATME * to continue the same random number sequence. * Changed on exit. * * D - COMPLEX array, dimension ( N ) * This array is used to specify the eigenvalues of A. If * MODE=0, then D is assumed to contain the eigenvalues * otherwise they will be computed according to MODE, COND, * DMAX, and RSIGN and placed in D. * Modified if MODE is nonzero. * * MODE - INTEGER * On entry this describes how the eigenvalues are to * be specified: * MODE = 0 means use D as input * MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND * MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND * MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) * MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) * MODE = 5 sets D to random numbers in the range * ( 1/COND , 1 ) such that their logarithms * are uniformly distributed. * MODE = 6 set D to random numbers from same distribution * as the rest of the matrix. * MODE < 0 has the same meaning as ABS(MODE), except that * the order of the elements of D is reversed. * Thus if MODE is between 1 and 4, D has entries ranging * from 1 to 1/COND, if between -1 and -4, D has entries * ranging from 1/COND to 1, * Not modified. * * COND - REAL * On entry, this is used as described under MODE above. * If used, it must be >= 1. Not modified. * * DMAX - COMPLEX * If MODE is neither -6, 0 nor 6, the contents of D, as * computed according to MODE and COND, will be scaled by * DMAX / max(abs(D(i))). Note that DMAX need not be * positive or real: if DMAX is negative or complex (or zero), * D will be scaled by a negative or complex number (or zero). * If RSIGN='F' then the largest (absolute) eigenvalue will be * equal to DMAX. * Not modified. * * EI - CHARACTER*1 (ignored) * Not modified. * * RSIGN - CHARACTER*1 * If MODE is not 0, 6, or -6, and RSIGN='T', then the * elements of D, as computed according to MODE and COND, will * be multiplied by a random complex number from the unit * circle |z| = 1. If RSIGN='F', they will not be. RSIGN may * only have the values 'T' or 'F'. * Not modified. * * UPPER - CHARACTER*1 * If UPPER='T', then the elements of A above the diagonal * will be set to random numbers out of DIST. If UPPER='F', * they will not. UPPER may only have the values 'T' or 'F'. * Not modified. * * SIM - CHARACTER*1 * If SIM='T', then A will be operated on by a "similarity * transform", i.e., multiplied on the left by a matrix X and * on the right by X inverse. X = U S V, where U and V are * random unitary matrices and S is a (diagonal) matrix of * singular values specified by DS, MODES, and CONDS. If * SIM='F', then A will not be transformed. * Not modified. * * DS - REAL array, dimension ( N ) * This array is used to specify the singular values of X, * in the same way that D specifies the eigenvalues of A. * If MODE=0, the DS contains the singular values, which * may not be zero. * Modified if MODE is nonzero. * * MODES - INTEGER * CONDS - REAL * Similar to MODE and COND, but for specifying the diagonal * of S. MODES=-6 and +6 are not allowed (since they would * result in randomly ill-conditioned eigenvalues.) * * KL - INTEGER * This specifies the lower bandwidth of the matrix. KL=1 * specifies upper Hessenberg form. If KL is at least N-1, * then A will have full lower bandwidth. * Not modified. * * KU - INTEGER * This specifies the upper bandwidth of the matrix. KU=1 * specifies lower Hessenberg form. If KU is at least N-1, * then A will have full upper bandwidth; if KU and KL * are both at least N-1, then A will be dense. Only one of * KU and KL may be less than N-1. * Not modified. * * ANORM - REAL * If ANORM is not negative, then A will be scaled by a non- * negative real number to make the maximum-element-norm of A * to be ANORM. * Not modified. * * A - COMPLEX array, dimension ( LDA, N ) * On exit A is the desired test matrix. * Modified. * * LDA - INTEGER * LDA specifies the first dimension of A as declared in the * calling program. LDA must be at least M. * Not modified. * * WORK - COMPLEX array, dimension ( 3*N ) * Workspace. * Modified. * * INFO - INTEGER * Error code. On exit, INFO will be set to one of the * following values: * 0 => normal return * -1 => N negative * -2 => DIST illegal string * -5 => MODE not in range -6 to 6 * -6 => COND less than 1.0, and MODE neither -6, 0 nor 6 * -9 => RSIGN is not 'T' or 'F' * -10 => UPPER is not 'T' or 'F' * -11 => SIM is not 'T' or 'F' * -12 => MODES=0 and DS has a zero singular value. * -13 => MODES is not in the range -5 to 5. * -14 => MODES is nonzero and CONDS is less than 1. * -15 => KL is less than 1. * -16 => KU is less than 1, or KL and KU are both less than * N-1. * -19 => LDA is less than M. * 1 => Error return from CLATM1 (computing D) * 2 => Cannot scale to DMAX (max. eigenvalue is 0) * 3 => Error return from SLATM1 (computing DS) * 4 => Error return from CLARGE * 5 => Zero singular value from SLATM1. * * ===================================================================== * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E+0 ) REAL ONE PARAMETER ( ONE = 1.0E+0 ) COMPLEX CZERO PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) ) COMPLEX CONE PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. LOGICAL BADS INTEGER I, IC, ICOLS, IDIST, IINFO, IR, IROWS, IRSIGN, $ ISIM, IUPPER, J, JC, JCR REAL RALPHA, TEMP COMPLEX ALPHA, TAU, XNORMS * .. * .. Local Arrays .. REAL TEMPA( 1 ) * .. * .. External Functions .. LOGICAL LSAME REAL CLANGE COMPLEX CLARND EXTERNAL LSAME, CLANGE, CLARND * .. * .. External Subroutines .. EXTERNAL CCOPY, CGEMV, CGERC, CLACGV, CLARFG, CLARGE, $ CLARNV, CLATM1, CLASET, CSCAL, CSSCAL, SLATM1, $ XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, CONJG, MAX, MOD * .. * .. Executable Statements .. * * 1) Decode and Test the input parameters. * Initialize flags & seed. * INFO = 0 * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Decode DIST * IF( LSAME( DIST, 'U' ) ) THEN IDIST = 1 ELSE IF( LSAME( DIST, 'S' ) ) THEN IDIST = 2 ELSE IF( LSAME( DIST, 'N' ) ) THEN IDIST = 3 ELSE IF( LSAME( DIST, 'D' ) ) THEN IDIST = 4 ELSE IDIST = -1 END IF * * Decode RSIGN * IF( LSAME( RSIGN, 'T' ) ) THEN IRSIGN = 1 ELSE IF( LSAME( RSIGN, 'F' ) ) THEN IRSIGN = 0 ELSE IRSIGN = -1 END IF * * Decode UPPER * IF( LSAME( UPPER, 'T' ) ) THEN IUPPER = 1 ELSE IF( LSAME( UPPER, 'F' ) ) THEN IUPPER = 0 ELSE IUPPER = -1 END IF * * Decode SIM * IF( LSAME( SIM, 'T' ) ) THEN ISIM = 1 ELSE IF( LSAME( SIM, 'F' ) ) THEN ISIM = 0 ELSE ISIM = -1 END IF * * Check DS, if MODES=0 and ISIM=1 * BADS = .FALSE. IF( MODES.EQ.0 .AND. ISIM.EQ.1 ) THEN DO 10 J = 1, N IF( DS( J ).EQ.ZERO ) $ BADS = .TRUE. 10 CONTINUE END IF * * Set INFO if an error * IF( N.LT.0 ) THEN INFO = -1 ELSE IF( IDIST.EQ.-1 ) THEN INFO = -2 ELSE IF( ABS( MODE ).GT.6 ) THEN INFO = -5 ELSE IF( ( MODE.NE.0 .AND. ABS( MODE ).NE.6 ) .AND. COND.LT.ONE ) $ THEN INFO = -6 ELSE IF( IRSIGN.EQ.-1 ) THEN INFO = -9 ELSE IF( IUPPER.EQ.-1 ) THEN INFO = -10 ELSE IF( ISIM.EQ.-1 ) THEN INFO = -11 ELSE IF( BADS ) THEN INFO = -12 ELSE IF( ISIM.EQ.1 .AND. ABS( MODES ).GT.5 ) THEN INFO = -13 ELSE IF( ISIM.EQ.1 .AND. MODES.NE.0 .AND. CONDS.LT.ONE ) THEN INFO = -14 ELSE IF( KL.LT.1 ) THEN INFO = -15 ELSE IF( KU.LT.1 .OR. ( KU.LT.N-1 .AND. KL.LT.N-1 ) ) THEN INFO = -16 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -19 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'CLATME', -INFO ) RETURN END IF * * Initialize random number generator * DO 20 I = 1, 4 ISEED( I ) = MOD( ABS( ISEED( I ) ), 4096 ) 20 CONTINUE * IF( MOD( ISEED( 4 ), 2 ).NE.1 ) $ ISEED( 4 ) = ISEED( 4 ) + 1 * * 2) Set up diagonal of A * * Compute D according to COND and MODE * CALL CLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, IINFO ) IF( IINFO.NE.0 ) THEN INFO = 1 RETURN END IF IF( MODE.NE.0 .AND. ABS( MODE ).NE.6 ) THEN * * Scale by DMAX * TEMP = ABS( D( 1 ) ) DO 30 I = 2, N TEMP = MAX( TEMP, ABS( D( I ) ) ) 30 CONTINUE * IF( TEMP.GT.ZERO ) THEN ALPHA = DMAX / TEMP ELSE INFO = 2 RETURN END IF * CALL CSCAL( N, ALPHA, D, 1 ) * END IF * CALL CLASET( 'Full', N, N, CZERO, CZERO, A, LDA ) CALL CCOPY( N, D, 1, A, LDA+1 ) * * 3) If UPPER='T', set upper triangle of A to random numbers. * IF( IUPPER.NE.0 ) THEN DO 40 JC = 2, N CALL CLARNV( IDIST, ISEED, JC-1, A( 1, JC ) ) 40 CONTINUE END IF * * 4) If SIM='T', apply similarity transformation. * * -1 * Transform is X A X , where X = U S V, thus * * it is U S V A V' (1/S) U' * IF( ISIM.NE.0 ) THEN * * Compute S (singular values of the eigenvector matrix) * according to CONDS and MODES * CALL SLATM1( MODES, CONDS, 0, 0, ISEED, DS, N, IINFO ) IF( IINFO.NE.0 ) THEN INFO = 3 RETURN END IF * * Multiply by V and V' * CALL CLARGE( N, A, LDA, ISEED, WORK, IINFO ) IF( IINFO.NE.0 ) THEN INFO = 4 RETURN END IF * * Multiply by S and (1/S) * DO 50 J = 1, N CALL CSSCAL( N, DS( J ), A( J, 1 ), LDA ) IF( DS( J ).NE.ZERO ) THEN CALL CSSCAL( N, ONE / DS( J ), A( 1, J ), 1 ) ELSE INFO = 5 RETURN END IF 50 CONTINUE * * Multiply by U and U' * CALL CLARGE( N, A, LDA, ISEED, WORK, IINFO ) IF( IINFO.NE.0 ) THEN INFO = 4 RETURN END IF END IF * * 5) Reduce the bandwidth. * IF( KL.LT.N-1 ) THEN * * Reduce bandwidth -- kill column * DO 60 JCR = KL + 1, N - 1 IC = JCR - KL IROWS = N + 1 - JCR ICOLS = N + KL - JCR * CALL CCOPY( IROWS, A( JCR, IC ), 1, WORK, 1 ) XNORMS = WORK( 1 ) CALL CLARFG( IROWS, XNORMS, WORK( 2 ), 1, TAU ) TAU = CONJG( TAU ) WORK( 1 ) = CONE ALPHA = CLARND( 5, ISEED ) * CALL CGEMV( 'C', IROWS, ICOLS, CONE, A( JCR, IC+1 ), LDA, $ WORK, 1, CZERO, WORK( IROWS+1 ), 1 ) CALL CGERC( IROWS, ICOLS, -TAU, WORK, 1, WORK( IROWS+1 ), 1, $ A( JCR, IC+1 ), LDA ) * CALL CGEMV( 'N', N, IROWS, CONE, A( 1, JCR ), LDA, WORK, 1, $ CZERO, WORK( IROWS+1 ), 1 ) CALL CGERC( N, IROWS, -CONJG( TAU ), WORK( IROWS+1 ), 1, $ WORK, 1, A( 1, JCR ), LDA ) * A( JCR, IC ) = XNORMS CALL CLASET( 'Full', IROWS-1, 1, CZERO, CZERO, $ A( JCR+1, IC ), LDA ) * CALL CSCAL( ICOLS+1, ALPHA, A( JCR, IC ), LDA ) CALL CSCAL( N, CONJG( ALPHA ), A( 1, JCR ), 1 ) 60 CONTINUE ELSE IF( KU.LT.N-1 ) THEN * * Reduce upper bandwidth -- kill a row at a time. * DO 70 JCR = KU + 1, N - 1 IR = JCR - KU IROWS = N + KU - JCR ICOLS = N + 1 - JCR * CALL CCOPY( ICOLS, A( IR, JCR ), LDA, WORK, 1 ) XNORMS = WORK( 1 ) CALL CLARFG( ICOLS, XNORMS, WORK( 2 ), 1, TAU ) TAU = CONJG( TAU ) WORK( 1 ) = CONE CALL CLACGV( ICOLS-1, WORK( 2 ), 1 ) ALPHA = CLARND( 5, ISEED ) * CALL CGEMV( 'N', IROWS, ICOLS, CONE, A( IR+1, JCR ), LDA, $ WORK, 1, CZERO, WORK( ICOLS+1 ), 1 ) CALL CGERC( IROWS, ICOLS, -TAU, WORK( ICOLS+1 ), 1, WORK, 1, $ A( IR+1, JCR ), LDA ) * CALL CGEMV( 'C', ICOLS, N, CONE, A( JCR, 1 ), LDA, WORK, 1, $ CZERO, WORK( ICOLS+1 ), 1 ) CALL CGERC( ICOLS, N, -CONJG( TAU ), WORK, 1, $ WORK( ICOLS+1 ), 1, A( JCR, 1 ), LDA ) * A( IR, JCR ) = XNORMS CALL CLASET( 'Full', 1, ICOLS-1, CZERO, CZERO, $ A( IR, JCR+1 ), LDA ) * CALL CSCAL( IROWS+1, ALPHA, A( IR, JCR ), 1 ) CALL CSCAL( N, CONJG( ALPHA ), A( JCR, 1 ), LDA ) 70 CONTINUE END IF * * Scale the matrix to have norm ANORM * IF( ANORM.GE.ZERO ) THEN TEMP = CLANGE( 'M', N, N, A, LDA, TEMPA ) IF( TEMP.GT.ZERO ) THEN RALPHA = ANORM / TEMP DO 80 J = 1, N CALL CSSCAL( N, RALPHA, A( 1, J ), 1 ) 80 CONTINUE END IF END IF * RETURN * * End of CLATME * END SHAR_EOF fi # end of overwriting check if test -f 'clatmr.f' then echo shar: will not over-write existing file "'clatmr.f'" else cat << SHAR_EOF > 'clatmr.f' SUBROUTINE CLATMR( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, $ RSIGN, GRADE, DL, MODEL, CONDL, DR, MODER, $ CONDR, PIVTNG, IPIVOT, KL, KU, SPARSE, ANORM, $ PACK, A, LDA, IWORK, INFO ) * * -- LAPACK test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER DIST, GRADE, PACK, PIVTNG, RSIGN, SYM INTEGER INFO, KL, KU, LDA, M, MODE, MODEL, MODER, N REAL ANORM, COND, CONDL, CONDR, SPARSE COMPLEX DMAX * .. * .. Array Arguments .. INTEGER IPIVOT( * ), ISEED( 4 ), IWORK( * ) COMPLEX A( LDA, * ), D( * ), DL( * ), DR( * ) * .. * * Purpose * ======= * * CLATMR generates random matrices of various types for testing * LAPACK programs. * * CLATMR operates by applying the following sequence of * operations: * * Generate a matrix A with random entries of distribution DIST * which is symmetric if SYM='S', Hermitian if SYM='H', and * nonsymmetric if SYM='N'. * * Set the diagonal to D, where D may be input or * computed according to MODE, COND, DMAX and RSIGN * as described below. * * Grade the matrix, if desired, from the left and/or right * as specified by GRADE. The inputs DL, MODEL, CONDL, DR, * MODER and CONDR also determine the grading as described * below. * * Permute, if desired, the rows and/or columns as specified by * PIVTNG and IPIVOT. * * Set random entries to zero, if desired, to get a random sparse * matrix as specified by SPARSE. * * Make A a band matrix, if desired, by zeroing out the matrix * outside a band of lower bandwidth KL and upper bandwidth KU. * * Scale A, if desired, to have maximum entry ANORM. * * Pack the matrix if desired. Options specified by PACK are: * no packing * zero out upper half (if symmetric or Hermitian) * zero out lower half (if symmetric or Hermitian) * store the upper half columnwise (if symmetric or Hermitian * or square upper triangular) * store the lower half columnwise (if symmetric or Hermitian * or square lower triangular) * same as upper half rowwise if symmetric * same as conjugate upper half rowwise if Hermitian * store the lower triangle in banded format * (if symmetric or Hermitian) * store the upper triangle in banded format * (if symmetric or Hermitian) * store the entire matrix in banded format * * Note: If two calls to CLATMR differ only in the PACK parameter, * they will generate mathematically equivalent matrices. * * If two calls to CLATMR both have full bandwidth (KL = M-1 * and KU = N-1), and differ only in the PIVTNG and PACK * parameters, then the matrices generated will differ only * in the order of the rows and/or columns, and otherwise * contain the same data. This consistency cannot be and * is not maintained with less than full bandwidth. * * Arguments * ========= * * M - INTEGER * Number of rows of A. Not modified. * * N - INTEGER * Number of columns of A. Not modified. * * DIST - CHARACTER*1 * On entry, DIST specifies the type of distribution to be used * to generate a random matrix . * 'U' => real and imaginary parts are independent * UNIFORM( 0, 1 ) ( 'U' for uniform ) * 'S' => real and imaginary parts are independent * UNIFORM( -1, 1 ) ( 'S' for symmetric ) * 'N' => real and imaginary parts are independent * NORMAL( 0, 1 ) ( 'N' for normal ) * 'D' => uniform on interior of unit disk ( 'D' for disk ) * Not modified. * * ISEED - INTEGER array, dimension (4) * On entry ISEED specifies the seed of the random number * generator. They should lie between 0 and 4095 inclusive, * and ISEED(4) should be odd. The random number generator * uses a linear congruential sequence limited to small * integers, and so should produce machine independent * random numbers. The values of ISEED are changed on * exit, and can be used in the next call to CLATMR * to continue the same random number sequence. * Changed on exit. * * SYM - CHARACTER*1 * If SYM='S', generated matrix is symmetric. * If SYM='H', generated matrix is Hermitian. * If SYM='N', generated matrix is nonsymmetric. * Not modified. * * D - COMPLEX array, dimension (min(M,N)) * On entry this array specifies the diagonal entries * of the diagonal of A. D may either be specified * on entry, or set according to MODE and COND as described * below. If the matrix is Hermitian, the real part of D * will be taken. May be changed on exit if MODE is nonzero. * * MODE - INTEGER * On entry describes how D is to be used: * MODE = 0 means use D as input * MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND * MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND * MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) * MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) * MODE = 5 sets D to random numbers in the range * ( 1/COND , 1 ) such that their logarithms * are uniformly distributed. * MODE = 6 set D to random numbers from same distribution * as the rest of the matrix. * MODE < 0 has the same meaning as ABS(MODE), except that * the order of the elements of D is reversed. * Thus if MODE is positive, D has entries ranging from * 1 to 1/COND, if negative, from 1/COND to 1, * Not modified. * * COND - REAL * On entry, used as described under MODE above. * If used, it must be >= 1. Not modified. * * DMAX - COMPLEX * If MODE neither -6, 0 nor 6, the diagonal is scaled by * DMAX / max(abs(D(i))), so that maximum absolute entry * of diagonal is abs(DMAX). If DMAX is complex (or zero), * diagonal will be scaled by a complex number (or zero). * * RSIGN - CHARACTER*1 * If MODE neither -6, 0 nor 6, specifies sign of diagonal * as follows: * 'T' => diagonal entries are multiplied by a random complex * number uniformly distributed with absolute value 1 * 'F' => diagonal unchanged * Not modified. * * GRADE - CHARACTER*1 * Specifies grading of matrix as follows: * 'N' => no grading * 'L' => matrix premultiplied by diag( DL ) * (only if matrix nonsymmetric) * 'R' => matrix postmultiplied by diag( DR ) * (only if matrix nonsymmetric) * 'B' => matrix premultiplied by diag( DL ) and * postmultiplied by diag( DR ) * (only if matrix nonsymmetric) * 'H' => matrix premultiplied by diag( DL ) and * postmultiplied by diag( CONJG(DL) ) * (only if matrix Hermitian or nonsymmetric) * 'S' => matrix premultiplied by diag( DL ) and * postmultiplied by diag( DL ) * (only if matrix symmetric or nonsymmetric) * 'E' => matrix premultiplied by diag( DL ) and * postmultiplied by inv( diag( DL ) ) * ( 'S' for similarity ) * (only if matrix nonsymmetric) * Note: if GRADE='S', then M must equal N. * Not modified. * * DL - COMPLEX array, dimension (M) * If MODEL=0, then on entry this array specifies the diagonal * entries of a diagonal matrix used as described under GRADE * above. If MODEL is not zero, then DL will be set according * to MODEL and CONDL, analogous to the way D is set according * to MODE and COND (except there is no DMAX parameter for DL). * If GRADE='E', then DL cannot have zero entries. * Not referenced if GRADE = 'N' or 'R'. Changed on exit. * * MODEL - INTEGER * This specifies how the diagonal array DL is to be computed, * just as MODE specifies how D is to be computed. * Not modified. * * CONDL - REAL * When MODEL is not zero, this specifies the condition number * of the computed DL. Not modified. * * DR - COMPLEX array, dimension (N) * If MODER=0, then on entry this array specifies the diagonal * entries of a diagonal matrix used as described under GRADE * above. If MODER is not zero, then DR will be set according * to MODER and CONDR, analogous to the way D is set according * to MODE and COND (except there is no DMAX parameter for DR). * Not referenced if GRADE = 'N', 'L', 'H' or 'S'. * Changed on exit. * * MODER - INTEGER * This specifies how the diagonal array DR is to be computed, * just as MODE specifies how D is to be computed. * Not modified. * * CONDR - REAL * When MODER is not zero, this specifies the condition number * of the computed DR. Not modified. * * PIVTNG - CHARACTER*1 * On entry specifies pivoting permutations as follows: * 'N' or ' ' => none. * 'L' => left or row pivoting (matrix must be nonsymmetric). * 'R' => right or column pivoting (matrix must be * nonsymmetric). * 'B' or 'F' => both or full pivoting, i.e., on both sides. * In this case, M must equal N * * If two calls to CLATMR both have full bandwidth (KL = M-1 * and KU = N-1), and differ only in the PIVTNG and PACK * parameters, then the matrices generated will differ only * in the order of the rows and/or columns, and otherwise * contain the same data. This consistency cannot be * maintained with less than full bandwidth. * * IPIVOT - INTEGER array, dimension (N or M) * This array specifies the permutation used. After the * basic matrix is generated, the rows, columns, or both * are permuted. If, say, row pivoting is selected, CLATMR * starts with the *last* row and interchanges the M-th and * IPIVOT(M)-th rows, then moves to the next-to-last row, * interchanging the (M-1)-th and the IPIVOT(M-1)-th rows, * and so on. In terms of "2-cycles", the permutation is * (1 IPIVOT(1)) (2 IPIVOT(2)) ... (M IPIVOT(M)) * where the rightmost cycle is applied first. This is the * *inverse* of the effect of pivoting in LINPACK. The idea * is that factoring (with pivoting) an identity matrix * which has been inverse-pivoted in this way should * result in a pivot vector identical to IPIVOT. * Not referenced if PIVTNG = 'N'. Not modified. * * SPARSE - REAL * On entry specifies the sparsity of the matrix if a sparse * matrix is to be generated. SPARSE should lie between * 0 and 1. To generate a sparse matrix, for each matrix entry * a uniform ( 0, 1 ) random number x is generated and * compared to SPARSE; if x is larger the matrix entry * is unchanged and if x is smaller the entry is set * to zero. Thus on the average a fraction SPARSE of the * entries will be set to zero. * Not modified. * * KL - INTEGER * On entry specifies the lower bandwidth of the matrix. For * example, KL=0 implies upper triangular, KL=1 implies upper * Hessenberg, and KL at least M-1 implies the matrix is not * banded. Must equal KU if matrix is symmetric or Hermitian. * Not modified. * * KU - INTEGER * On entry specifies the upper bandwidth of the matrix. For * example, KU=0 implies lower triangular, KU=1 implies lower * Hessenberg, and KU at least N-1 implies the matrix is not * banded. Must equal KL if matrix is symmetric or Hermitian. * Not modified. * * ANORM - REAL * On entry specifies maximum entry of output matrix * (output matrix will by multiplied by a constant so that * its largest absolute entry equal ANORM) * if ANORM is nonnegative. If ANORM is negative no scaling * is done. Not modified. * * PACK - CHARACTER*1 * On entry specifies packing of matrix as follows: * 'N' => no packing * 'U' => zero out all subdiagonal entries * (if symmetric or Hermitian) * 'L' => zero out all superdiagonal entries * (if symmetric or Hermitian) * 'C' => store the upper triangle columnwise * (only if matrix symmetric or Hermitian or * square upper triangular) * 'R' => store the lower triangle columnwise * (only if matrix symmetric or Hermitian or * square lower triangular) * (same as upper half rowwise if symmetric) * (same as conjugate upper half rowwise if Hermitian) * 'B' => store the lower triangle in band storage scheme * (only if matrix symmetric or Hermitian) * 'Q' => store the upper triangle in band storage scheme * (only if matrix symmetric or Hermitian) * 'Z' => store the entire matrix in band storage scheme * (pivoting can be provided for by using this * option to store A in the trailing rows of * the allocated storage) * * Using these options, the various LAPACK packed and banded * storage schemes can be obtained: * GB - use 'Z' * PB, HB or TB - use 'B' or 'Q' * PP, HP or TP - use 'C' or 'R' * * If two calls to CLATMR differ only in the PACK parameter, * they will generate mathematically equivalent matrices. * Not modified. * * A - COMPLEX array, dimension (LDA,N) * On exit A is the desired test matrix. Only those * entries of A which are significant on output * will be referenced (even if A is in packed or band * storage format). The 'unoccupied corners' of A in * band format will be zeroed out. * * LDA - INTEGER * on entry LDA specifies the first dimension of A as * declared in the calling program. * If PACK='N', 'U' or 'L', LDA must be at least max ( 1, M ). * If PACK='C' or 'R', LDA must be at least 1. * If PACK='B', or 'Q', LDA must be MIN ( KU+1, N ) * If PACK='Z', LDA must be at least KUU+KLL+1, where * KUU = MIN ( KU, N-1 ) and KLL = MIN ( KL, N-1 ) * Not modified. * * IWORK - INTEGER array, dimension (N or M) * Workspace. Not referenced if PIVTNG = 'N'. Changed on exit. * * INFO - INTEGER * Error parameter on exit: * 0 => normal return * -1 => M negative or unequal to N and SYM='S' or 'H' * -2 => N negative * -3 => DIST illegal string * -5 => SYM illegal string * -7 => MODE not in range -6 to 6 * -8 => COND less than 1.0, and MODE neither -6, 0 nor 6 * -10 => MODE neither -6, 0 nor 6 and RSIGN illegal string * -11 => GRADE illegal string, or GRADE='E' and * M not equal to N, or GRADE='L', 'R', 'B', 'S' or 'E' * and SYM = 'H', or GRADE='L', 'R', 'B', 'H' or 'E' * and SYM = 'S' * -12 => GRADE = 'E' and DL contains zero * -13 => MODEL not in range -6 to 6 and GRADE= 'L', 'B', 'H', * 'S' or 'E' * -14 => CONDL less than 1.0, GRADE='L', 'B', 'H', 'S' or 'E', * and MODEL neither -6, 0 nor 6 * -16 => MODER not in range -6 to 6 and GRADE= 'R' or 'B' * -17 => CONDR less than 1.0, GRADE='R' or 'B', and * MODER neither -6, 0 nor 6 * -18 => PIVTNG illegal string, or PIVTNG='B' or 'F' and * M not equal to N, or PIVTNG='L' or 'R' and SYM='S' * or 'H' * -19 => IPIVOT contains out of range number and * PIVTNG not equal to 'N' * -20 => KL negative * -21 => KU negative, or SYM='S' or 'H' and KU not equal to KL * -22 => SPARSE not in range 0. to 1. * -24 => PACK illegal string, or PACK='U', 'L', 'B' or 'Q' * and SYM='N', or PACK='C' and SYM='N' and either KL * not equal to 0 or N not equal to M, or PACK='R' and * SYM='N', and either KU not equal to 0 or N not equal * to M * -26 => LDA too small * 1 => Error return from CLATM1 (computing D) * 2 => Cannot scale diagonal to DMAX (max. entry is 0) * 3 => Error return from CLATM1 (computing DL) * 4 => Error return from CLATM1 (computing DR) * 5 => ANORM is positive, but matrix constructed prior to * attempting to scale it to have norm ANORM, is zero * * ===================================================================== * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E0 ) REAL ONE PARAMETER ( ONE = 1.0E0 ) COMPLEX CONE PARAMETER ( CONE = ( 1.0E0, 0.0E0 ) ) COMPLEX CZERO PARAMETER ( CZERO = ( 0.0E0, 0.0E0 ) ) * .. * .. Local Scalars .. LOGICAL BADPVT, DZERO, FULBND INTEGER I, IDIST, IGRADE, IISUB, IPACK, IPVTNG, IRSIGN, $ ISUB, ISYM, J, JJSUB, JSUB, K, KLL, KUU, MNMIN, $ MNSUB, MXSUB, NPVTS REAL ONORM, TEMP COMPLEX CALPHA, CTEMP * .. * .. Local Arrays .. REAL TEMPA( 1 ) * .. * .. External Functions .. LOGICAL LSAME REAL CLANGB, CLANGE, CLANSB, CLANSP, CLANSY COMPLEX CLATM2, CLATM3 EXTERNAL LSAME, CLANGB, CLANGE, CLANSB, CLANSP, CLANSY, $ CLATM2, CLATM3 * .. * .. External Subroutines .. EXTERNAL CLATM1, CSSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, CONJG, MAX, MIN, MOD, REAL * .. * .. Executable Statements .. * * 1) Decode and Test the input parameters. * Initialize flags & seed. * INFO = 0 * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * * Decode DIST * IF( LSAME( DIST, 'U' ) ) THEN IDIST = 1 ELSE IF( LSAME( DIST, 'S' ) ) THEN IDIST = 2 ELSE IF( LSAME( DIST, 'N' ) ) THEN IDIST = 3 ELSE IF( LSAME( DIST, 'D' ) ) THEN IDIST = 4 ELSE IDIST = -1 END IF * * Decode SYM * IF( LSAME( SYM, 'H' ) ) THEN ISYM = 0 ELSE IF( LSAME( SYM, 'N' ) ) THEN ISYM = 1 ELSE IF( LSAME( SYM, 'S' ) ) THEN ISYM = 2 ELSE ISYM = -1 END IF * * Decode RSIGN * IF( LSAME( RSIGN, 'F' ) ) THEN IRSIGN = 0 ELSE IF( LSAME( RSIGN, 'T' ) ) THEN IRSIGN = 1 ELSE IRSIGN = -1 END IF * * Decode PIVTNG * IF( LSAME( PIVTNG, 'N' ) ) THEN IPVTNG = 0 ELSE IF( LSAME( PIVTNG, ' ' ) ) THEN IPVTNG = 0 ELSE IF( LSAME( PIVTNG, 'L' ) ) THEN IPVTNG = 1 NPVTS = M ELSE IF( LSAME( PIVTNG, 'R' ) ) THEN IPVTNG = 2 NPVTS = N ELSE IF( LSAME( PIVTNG, 'B' ) ) THEN IPVTNG = 3 NPVTS = MIN( N, M ) ELSE IF( LSAME( PIVTNG, 'F' ) ) THEN IPVTNG = 3 NPVTS = MIN( N, M ) ELSE IPVTNG = -1 END IF * * Decode GRADE * IF( LSAME( GRADE, 'N' ) ) THEN IGRADE = 0 ELSE IF( LSAME( GRADE, 'L' ) ) THEN IGRADE = 1 ELSE IF( LSAME( GRADE, 'R' ) ) THEN IGRADE = 2 ELSE IF( LSAME( GRADE, 'B' ) ) THEN IGRADE = 3 ELSE IF( LSAME( GRADE, 'E' ) ) THEN IGRADE = 4 ELSE IF( LSAME( GRADE, 'H' ) ) THEN IGRADE = 5 ELSE IF( LSAME( GRADE, 'S' ) ) THEN IGRADE = 6 ELSE IGRADE = -1 END IF * * Decode PACK * IF( LSAME( PACK, 'N' ) ) THEN IPACK = 0 ELSE IF( LSAME( PACK, 'U' ) ) THEN IPACK = 1 ELSE IF( LSAME( PACK, 'L' ) ) THEN IPACK = 2 ELSE IF( LSAME( PACK, 'C' ) ) THEN IPACK = 3 ELSE IF( LSAME( PACK, 'R' ) ) THEN IPACK = 4 ELSE IF( LSAME( PACK, 'B' ) ) THEN IPACK = 5 ELSE IF( LSAME( PACK, 'Q' ) ) THEN IPACK = 6 ELSE IF( LSAME( PACK, 'Z' ) ) THEN IPACK = 7 ELSE IPACK = -1 END IF * * Set certain internal parameters * MNMIN = MIN( M, N ) KLL = MIN( KL, M-1 ) KUU = MIN( KU, N-1 ) * * If inv(DL) is used, check to see if DL has a zero entry. * DZERO = .FALSE. IF( IGRADE.EQ.4 .AND. MODEL.EQ.0 ) THEN DO 10 I = 1, M IF( DL( I ).EQ.CZERO ) $ DZERO = .TRUE. 10 CONTINUE END IF * * Check values in IPIVOT * BADPVT = .FALSE. IF( IPVTNG.GT.0 ) THEN DO 20 J = 1, NPVTS IF( IPIVOT( J ).LE.0 .OR. IPIVOT( J ).GT.NPVTS ) $ BADPVT = .TRUE. 20 CONTINUE END IF * * Set INFO if an error * IF( M.LT.0 ) THEN INFO = -1 ELSE IF( M.NE.N .AND. ( ISYM.EQ.0 .OR. ISYM.EQ.2 ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( IDIST.EQ.-1 ) THEN INFO = -3 ELSE IF( ISYM.EQ.-1 ) THEN INFO = -5 ELSE IF( MODE.LT.-6 .OR. MODE.GT.6 ) THEN INFO = -7 ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND. $ COND.LT.ONE ) THEN INFO = -8 ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND. $ IRSIGN.EQ.-1 ) THEN INFO = -10 ELSE IF( IGRADE.EQ.-1 .OR. ( IGRADE.EQ.4 .AND. M.NE.N ) .OR. $ ( ( IGRADE.EQ.1 .OR. IGRADE.EQ.2 .OR. IGRADE.EQ.3 .OR. $ IGRADE.EQ.4 .OR. IGRADE.EQ.6 ) .AND. ISYM.EQ.0 ) .OR. $ ( ( IGRADE.EQ.1 .OR. IGRADE.EQ.2 .OR. IGRADE.EQ.3 .OR. $ IGRADE.EQ.4 .OR. IGRADE.EQ.5 ) .AND. ISYM.EQ.2 ) ) THEN INFO = -11 ELSE IF( IGRADE.EQ.4 .AND. DZERO ) THEN INFO = -12 ELSE IF( ( IGRADE.EQ.1 .OR. IGRADE.EQ.3 .OR. IGRADE.EQ.4 .OR. $ IGRADE.EQ.5 .OR. IGRADE.EQ.6 ) .AND. $ ( MODEL.LT.-6 .OR. MODEL.GT.6 ) ) THEN INFO = -13 ELSE IF( ( IGRADE.EQ.1 .OR. IGRADE.EQ.3 .OR. IGRADE.EQ.4 .OR. $ IGRADE.EQ.5 .OR. IGRADE.EQ.6 ) .AND. $ ( MODEL.NE.-6 .AND. MODEL.NE.0 .AND. MODEL.NE.6 ) .AND. $ CONDL.LT.ONE ) THEN INFO = -14 ELSE IF( ( IGRADE.EQ.2 .OR. IGRADE.EQ.3 ) .AND. $ ( MODER.LT.-6 .OR. MODER.GT.6 ) ) THEN INFO = -16 ELSE IF( ( IGRADE.EQ.2 .OR. IGRADE.EQ.3 ) .AND. $ ( MODER.NE.-6 .AND. MODER.NE.0 .AND. MODER.NE.6 ) .AND. $ CONDR.LT.ONE ) THEN INFO = -17 ELSE IF( IPVTNG.EQ.-1 .OR. ( IPVTNG.EQ.3 .AND. M.NE.N ) .OR. $ ( ( IPVTNG.EQ.1 .OR. IPVTNG.EQ.2 ) .AND. ( ISYM.EQ.0 .OR. $ ISYM.EQ.2 ) ) ) THEN INFO = -18 ELSE IF( IPVTNG.NE.0 .AND. BADPVT ) THEN INFO = -19 ELSE IF( KL.LT.0 ) THEN INFO = -20 ELSE IF( KU.LT.0 .OR. ( ( ISYM.EQ.0 .OR. ISYM.EQ.2 ) .AND. KL.NE. $ KU ) ) THEN INFO = -21 ELSE IF( SPARSE.LT.ZERO .OR. SPARSE.GT.ONE ) THEN INFO = -22 ELSE IF( IPACK.EQ.-1 .OR. ( ( IPACK.EQ.1 .OR. IPACK.EQ.2 .OR. $ IPACK.EQ.5 .OR. IPACK.EQ.6 ) .AND. ISYM.EQ.1 ) .OR. $ ( IPACK.EQ.3 .AND. ISYM.EQ.1 .AND. ( KL.NE.0 .OR. M.NE. $ N ) ) .OR. ( IPACK.EQ.4 .AND. ISYM.EQ.1 .AND. ( KU.NE. $ 0 .OR. M.NE.N ) ) ) THEN INFO = -24 ELSE IF( ( ( IPACK.EQ.0 .OR. IPACK.EQ.1 .OR. IPACK.EQ.2 ) .AND. $ LDA.LT.MAX( 1, M ) ) .OR. ( ( IPACK.EQ.3 .OR. IPACK.EQ. $ 4 ) .AND. LDA.LT.1 ) .OR. ( ( IPACK.EQ.5 .OR. IPACK.EQ. $ 6 ) .AND. LDA.LT.KUU+1 ) .OR. $ ( IPACK.EQ.7 .AND. LDA.LT.KLL+KUU+1 ) ) THEN INFO = -26 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'CLATMR', -INFO ) RETURN END IF * * Decide if we can pivot consistently * FULBND = .FALSE. IF( KUU.EQ.N-1 .AND. KLL.EQ.M-1 ) $ FULBND = .TRUE. * * Initialize random number generator * DO 30 I = 1, 4 ISEED( I ) = MOD( ABS( ISEED( I ) ), 4096 ) 30 CONTINUE * ISEED( 4 ) = 2*( ISEED( 4 ) / 2 ) + 1 * * 2) Set up D, DL, and DR, if indicated. * * Compute D according to COND and MODE * CALL CLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, MNMIN, INFO ) IF( INFO.NE.0 ) THEN INFO = 1 RETURN END IF IF( MODE.NE.0 .AND. MODE.NE.-6 .AND. MODE.NE.6 ) THEN * * Scale by DMAX * TEMP = ABS( D( 1 ) ) DO 40 I = 2, MNMIN TEMP = MAX( TEMP, ABS( D( I ) ) ) 40 CONTINUE IF( TEMP.EQ.ZERO .AND. DMAX.NE.CZERO ) THEN INFO = 2 RETURN END IF IF( TEMP.NE.ZERO ) THEN CALPHA = DMAX / TEMP ELSE CALPHA = CONE END IF DO 50 I = 1, MNMIN D( I ) = CALPHA*D( I ) 50 CONTINUE * END IF * * If matrix Hermitian, make D real * IF( ISYM.EQ.0 ) THEN DO 60 I = 1, MNMIN D( I ) = REAL( D( I ) ) 60 CONTINUE END IF * * Compute DL if grading set * IF( IGRADE.EQ.1 .OR. IGRADE.EQ.3 .OR. IGRADE.EQ.4 .OR. IGRADE.EQ. $ 5 .OR. IGRADE.EQ.6 ) THEN CALL CLATM1( MODEL, CONDL, 0, IDIST, ISEED, DL, M, INFO ) IF( INFO.NE.0 ) THEN INFO = 3 RETURN END IF END IF * * Compute DR if grading set * IF( IGRADE.EQ.2 .OR. IGRADE.EQ.3 ) THEN CALL CLATM1( MODER, CONDR, 0, IDIST, ISEED, DR, N, INFO ) IF( INFO.NE.0 ) THEN INFO = 4 RETURN END IF END IF * * 3) Generate IWORK if pivoting * IF( IPVTNG.GT.0 ) THEN DO 70 I = 1, NPVTS IWORK( I ) = I 70 CONTINUE IF( FULBND ) THEN DO 80 I = 1, NPVTS K = IPIVOT( I ) J = IWORK( I ) IWORK( I ) = IWORK( K ) IWORK( K ) = J 80 CONTINUE ELSE DO 90 I = NPVTS, 1, -1 K = IPIVOT( I ) J = IWORK( I ) IWORK( I ) = IWORK( K ) IWORK( K ) = J 90 CONTINUE END IF END IF * * 4) Generate matrices for each kind of PACKing * Always sweep matrix columnwise (if symmetric, upper * half only) so that matrix generated does not depend * on PACK * IF( FULBND ) THEN * * Use CLATM3 so matrices generated with differing PIVOTing only * differ only in the order of their rows and/or columns. * IF( IPACK.EQ.0 ) THEN IF( ISYM.EQ.0 ) THEN DO 110 J = 1, N DO 100 I = 1, J CTEMP = CLATM3( M, N, I, J, ISUB, JSUB, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) A( ISUB, JSUB ) = CTEMP A( JSUB, ISUB ) = CONJG( CTEMP ) 100 CONTINUE 110 CONTINUE ELSE IF( ISYM.EQ.1 ) THEN DO 130 J = 1, N DO 120 I = 1, M CTEMP = CLATM3( M, N, I, J, ISUB, JSUB, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) A( ISUB, JSUB ) = CTEMP 120 CONTINUE 130 CONTINUE ELSE IF( ISYM.EQ.2 ) THEN DO 150 J = 1, N DO 140 I = 1, J CTEMP = CLATM3( M, N, I, J, ISUB, JSUB, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) A( ISUB, JSUB ) = CTEMP A( JSUB, ISUB ) = CTEMP 140 CONTINUE 150 CONTINUE END IF * ELSE IF( IPACK.EQ.1 ) THEN * DO 170 J = 1, N DO 160 I = 1, J CTEMP = CLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, $ SPARSE ) MNSUB = MIN( ISUB, JSUB ) MXSUB = MAX( ISUB, JSUB ) IF( MXSUB.EQ.ISUB .AND. ISYM.EQ.0 ) THEN A( MNSUB, MXSUB ) = CONJG( CTEMP ) ELSE A( MNSUB, MXSUB ) = CTEMP END IF IF( MNSUB.NE.MXSUB ) $ A( MXSUB, MNSUB ) = CZERO 160 CONTINUE 170 CONTINUE * ELSE IF( IPACK.EQ.2 ) THEN * DO 190 J = 1, N DO 180 I = 1, J CTEMP = CLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, $ SPARSE ) MNSUB = MIN( ISUB, JSUB ) MXSUB = MAX( ISUB, JSUB ) IF( MXSUB.EQ.JSUB .AND. ISYM.EQ.0 ) THEN A( MXSUB, MNSUB ) = CONJG( CTEMP ) ELSE A( MXSUB, MNSUB ) = CTEMP END IF IF( MNSUB.NE.MXSUB ) $ A( MNSUB, MXSUB ) = CZERO 180 CONTINUE 190 CONTINUE * ELSE IF( IPACK.EQ.3 ) THEN * DO 210 J = 1, N DO 200 I = 1, J CTEMP = CLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, $ SPARSE ) * * Compute K = location of (ISUB,JSUB) entry in packed * array * MNSUB = MIN( ISUB, JSUB ) MXSUB = MAX( ISUB, JSUB ) K = MXSUB*( MXSUB-1 ) / 2 + MNSUB * * Convert K to (IISUB,JJSUB) location * JJSUB = ( K-1 ) / LDA + 1 IISUB = K - LDA*( JJSUB-1 ) * IF( MXSUB.EQ.ISUB .AND. ISYM.EQ.0 ) THEN A( IISUB, JJSUB ) = CONJG( CTEMP ) ELSE A( IISUB, JJSUB ) = CTEMP END IF 200 CONTINUE 210 CONTINUE * ELSE IF( IPACK.EQ.4 ) THEN * DO 230 J = 1, N DO 220 I = 1, J CTEMP = CLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, $ SPARSE ) * * Compute K = location of (I,J) entry in packed array * MNSUB = MIN( ISUB, JSUB ) MXSUB = MAX( ISUB, JSUB ) IF( MNSUB.EQ.1 ) THEN K = MXSUB ELSE K = N*( N+1 ) / 2 - ( N-MNSUB+1 )*( N-MNSUB+2 ) / $ 2 + MXSUB - MNSUB + 1 END IF * * Convert K to (IISUB,JJSUB) location * JJSUB = ( K-1 ) / LDA + 1 IISUB = K - LDA*( JJSUB-1 ) * IF( MXSUB.EQ.JSUB .AND. ISYM.EQ.0 ) THEN A( IISUB, JJSUB ) = CONJG( CTEMP ) ELSE A( IISUB, JJSUB ) = CTEMP END IF 220 CONTINUE 230 CONTINUE * ELSE IF( IPACK.EQ.5 ) THEN * DO 250 J = 1, N DO 240 I = J - KUU, J IF( I.LT.1 ) THEN A( J-I+1, I+N ) = CZERO ELSE CTEMP = CLATM3( M, N, I, J, ISUB, JSUB, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) MNSUB = MIN( ISUB, JSUB ) MXSUB = MAX( ISUB, JSUB ) IF( MXSUB.EQ.JSUB .AND. ISYM.EQ.0 ) THEN A( MXSUB-MNSUB+1, MNSUB ) = CONJG( CTEMP ) ELSE A( MXSUB-MNSUB+1, MNSUB ) = CTEMP END IF END IF 240 CONTINUE 250 CONTINUE * ELSE IF( IPACK.EQ.6 ) THEN * DO 270 J = 1, N DO 260 I = J - KUU, J CTEMP = CLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, $ SPARSE ) MNSUB = MIN( ISUB, JSUB ) MXSUB = MAX( ISUB, JSUB ) IF( MXSUB.EQ.ISUB .AND. ISYM.EQ.0 ) THEN A( MNSUB-MXSUB+KUU+1, MXSUB ) = CONJG( CTEMP ) ELSE A( MNSUB-MXSUB+KUU+1, MXSUB ) = CTEMP END IF 260 CONTINUE 270 CONTINUE * ELSE IF( IPACK.EQ.7 ) THEN * IF( ISYM.NE.1 ) THEN DO 290 J = 1, N DO 280 I = J - KUU, J CTEMP = CLATM3( M, N, I, J, ISUB, JSUB, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) MNSUB = MIN( ISUB, JSUB ) MXSUB = MAX( ISUB, JSUB ) IF( I.LT.1 ) $ A( J-I+1+KUU, I+N ) = CZERO IF( MXSUB.EQ.ISUB .AND. ISYM.EQ.0 ) THEN A( MNSUB-MXSUB+KUU+1, MXSUB ) = CONJG( CTEMP ) ELSE A( MNSUB-MXSUB+KUU+1, MXSUB ) = CTEMP END IF IF( I.GE.1 .AND. MNSUB.NE.MXSUB ) THEN IF( MNSUB.EQ.ISUB .AND. ISYM.EQ.0 ) THEN A( MXSUB-MNSUB+1+KUU, $ MNSUB ) = CONJG( CTEMP ) ELSE A( MXSUB-MNSUB+1+KUU, MNSUB ) = CTEMP END IF END IF 280 CONTINUE 290 CONTINUE ELSE IF( ISYM.EQ.1 ) THEN DO 310 J = 1, N DO 300 I = J - KUU, J + KLL CTEMP = CLATM3( M, N, I, J, ISUB, JSUB, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) A( ISUB-JSUB+KUU+1, JSUB ) = CTEMP 300 CONTINUE 310 CONTINUE END IF * END IF * ELSE * * Use CLATM2 * IF( IPACK.EQ.0 ) THEN IF( ISYM.EQ.0 ) THEN DO 330 J = 1, N DO 320 I = 1, J A( I, J ) = CLATM2( M, N, I, J, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) A( J, I ) = CONJG( A( I, J ) ) 320 CONTINUE 330 CONTINUE ELSE IF( ISYM.EQ.1 ) THEN DO 350 J = 1, N DO 340 I = 1, M A( I, J ) = CLATM2( M, N, I, J, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) 340 CONTINUE 350 CONTINUE ELSE IF( ISYM.EQ.2 ) THEN DO 370 J = 1, N DO 360 I = 1, J A( I, J ) = CLATM2( M, N, I, J, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) A( J, I ) = A( I, J ) 360 CONTINUE 370 CONTINUE END IF * ELSE IF( IPACK.EQ.1 ) THEN * DO 390 J = 1, N DO 380 I = 1, J A( I, J ) = CLATM2( M, N, I, J, KL, KU, IDIST, ISEED, $ D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE ) IF( I.NE.J ) $ A( J, I ) = CZERO 380 CONTINUE 390 CONTINUE * ELSE IF( IPACK.EQ.2 ) THEN * DO 410 J = 1, N DO 400 I = 1, J IF( ISYM.EQ.0 ) THEN A( J, I ) = CONJG( CLATM2( M, N, I, J, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, DR, $ IPVTNG, IWORK, SPARSE ) ) ELSE A( J, I ) = CLATM2( M, N, I, J, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) END IF IF( I.NE.J ) $ A( I, J ) = CZERO 400 CONTINUE 410 CONTINUE * ELSE IF( IPACK.EQ.3 ) THEN * ISUB = 0 JSUB = 1 DO 430 J = 1, N DO 420 I = 1, J ISUB = ISUB + 1 IF( ISUB.GT.LDA ) THEN ISUB = 1 JSUB = JSUB + 1 END IF A( ISUB, JSUB ) = CLATM2( M, N, I, J, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) 420 CONTINUE 430 CONTINUE * ELSE IF( IPACK.EQ.4 ) THEN * IF( ISYM.EQ.0 .OR. ISYM.EQ.2 ) THEN DO 450 J = 1, N DO 440 I = 1, J * * Compute K = location of (I,J) entry in packed array * IF( I.EQ.1 ) THEN K = J ELSE K = N*( N+1 ) / 2 - ( N-I+1 )*( N-I+2 ) / 2 + $ J - I + 1 END IF * * Convert K to (ISUB,JSUB) location * JSUB = ( K-1 ) / LDA + 1 ISUB = K - LDA*( JSUB-1 ) * A( ISUB, JSUB ) = CLATM2( M, N, I, J, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, DR, $ IPVTNG, IWORK, SPARSE ) IF( ISYM.EQ.0 ) $ A( ISUB, JSUB ) = CONJG( A( ISUB, JSUB ) ) 440 CONTINUE 450 CONTINUE ELSE ISUB = 0 JSUB = 1 DO 470 J = 1, N DO 460 I = J, M ISUB = ISUB + 1 IF( ISUB.GT.LDA ) THEN ISUB = 1 JSUB = JSUB + 1 END IF A( ISUB, JSUB ) = CLATM2( M, N, I, J, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, DR, $ IPVTNG, IWORK, SPARSE ) 460 CONTINUE 470 CONTINUE END IF * ELSE IF( IPACK.EQ.5 ) THEN * DO 490 J = 1, N DO 480 I = J - KUU, J IF( I.LT.1 ) THEN A( J-I+1, I+N ) = CZERO ELSE IF( ISYM.EQ.0 ) THEN A( J-I+1, I ) = CONJG( CLATM2( M, N, I, J, KL, $ KU, IDIST, ISEED, D, IGRADE, DL, $ DR, IPVTNG, IWORK, SPARSE ) ) ELSE A( J-I+1, I ) = CLATM2( M, N, I, J, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, DR, $ IPVTNG, IWORK, SPARSE ) END IF END IF 480 CONTINUE 490 CONTINUE * ELSE IF( IPACK.EQ.6 ) THEN * DO 510 J = 1, N DO 500 I = J - KUU, J A( I-J+KUU+1, J ) = CLATM2( M, N, I, J, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) 500 CONTINUE 510 CONTINUE * ELSE IF( IPACK.EQ.7 ) THEN * IF( ISYM.NE.1 ) THEN DO 530 J = 1, N DO 520 I = J - KUU, J A( I-J+KUU+1, J ) = CLATM2( M, N, I, J, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, $ DR, IPVTNG, IWORK, SPARSE ) IF( I.LT.1 ) $ A( J-I+1+KUU, I+N ) = CZERO IF( I.GE.1 .AND. I.NE.J ) THEN IF( ISYM.EQ.0 ) THEN A( J-I+1+KUU, I ) = CONJG( A( I-J+KUU+1, $ J ) ) ELSE A( J-I+1+KUU, I ) = A( I-J+KUU+1, J ) END IF END IF 520 CONTINUE 530 CONTINUE ELSE IF( ISYM.EQ.1 ) THEN DO 550 J = 1, N DO 540 I = J - KUU, J + KLL A( I-J+KUU+1, J ) = CLATM2( M, N, I, J, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, $ DR, IPVTNG, IWORK, SPARSE ) 540 CONTINUE 550 CONTINUE END IF * END IF * END IF * * 5) Scaling the norm * IF( IPACK.EQ.0 ) THEN ONORM = CLANGE( 'M', M, N, A, LDA, TEMPA ) ELSE IF( IPACK.EQ.1 ) THEN ONORM = CLANSY( 'M', 'U', N, A, LDA, TEMPA ) ELSE IF( IPACK.EQ.2 ) THEN ONORM = CLANSY( 'M', 'L', N, A, LDA, TEMPA ) ELSE IF( IPACK.EQ.3 ) THEN ONORM = CLANSP( 'M', 'U', N, A, TEMPA ) ELSE IF( IPACK.EQ.4 ) THEN ONORM = CLANSP( 'M', 'L', N, A, TEMPA ) ELSE IF( IPACK.EQ.5 ) THEN ONORM = CLANSB( 'M', 'L', N, KLL, A, LDA, TEMPA ) ELSE IF( IPACK.EQ.6 ) THEN ONORM = CLANSB( 'M', 'U', N, KUU, A, LDA, TEMPA ) ELSE IF( IPACK.EQ.7 ) THEN ONORM = CLANGB( 'M', N, KLL, KUU, A, LDA, TEMPA ) END IF * IF( ANORM.GE.ZERO ) THEN * IF( ANORM.GT.ZERO .AND. ONORM.EQ.ZERO ) THEN * * Desired scaling impossible * INFO = 5 RETURN * ELSE IF( ( ANORM.GT.ONE .AND. ONORM.LT.ONE ) .OR. $ ( ANORM.LT.ONE .AND. ONORM.GT.ONE ) ) THEN * * Scale carefully to avoid over / underflow * IF( IPACK.LE.2 ) THEN DO 560 J = 1, N CALL CSSCAL( M, ONE / ONORM, A( 1, J ), 1 ) CALL CSSCAL( M, ANORM, A( 1, J ), 1 ) 560 CONTINUE * ELSE IF( IPACK.EQ.3 .OR. IPACK.EQ.4 ) THEN * CALL CSSCAL( N*( N+1 ) / 2, ONE / ONORM, A, 1 ) CALL CSSCAL( N*( N+1 ) / 2, ANORM, A, 1 ) * ELSE IF( IPACK.GE.5 ) THEN * DO 570 J = 1, N CALL CSSCAL( KLL+KUU+1, ONE / ONORM, A( 1, J ), 1 ) CALL CSSCAL( KLL+KUU+1, ANORM, A( 1, J ), 1 ) 570 CONTINUE * END IF * ELSE * * Scale straightforwardly * IF( IPACK.LE.2 ) THEN DO 580 J = 1, N CALL CSSCAL( M, ANORM / ONORM, A( 1, J ), 1 ) 580 CONTINUE * ELSE IF( IPACK.EQ.3 .OR. IPACK.EQ.4 ) THEN * CALL CSSCAL( N*( N+1 ) / 2, ANORM / ONORM, A, 1 ) * ELSE IF( IPACK.GE.5 ) THEN * DO 590 J = 1, N CALL CSSCAL( KLL+KUU+1, ANORM / ONORM, A( 1, J ), 1 ) 590 CONTINUE END IF * END IF * END IF * * End of CLATMR * END SHAR_EOF fi # end of overwriting check if test -f 'clatms.f' then echo shar: will not over-write existing file "'clatms.f'" else cat << SHAR_EOF > 'clatms.f' SUBROUTINE CLATMS( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, $ KL, KU, PACK, A, LDA, WORK, INFO ) * * -- LAPACK test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER DIST, PACK, SYM INTEGER INFO, KL, KU, LDA, M, MODE, N REAL COND, DMAX * .. * .. Array Arguments .. INTEGER ISEED( 4 ) REAL D( * ) COMPLEX A( LDA, * ), WORK( * ) * .. * * Purpose * ======= * * CLATMS generates random matrices with specified singular values * (or hermitian with specified eigenvalues) * for testing LAPACK programs. * * CLATMS operates by applying the following sequence of * operations: * * Set the diagonal to D, where D may be input or * computed according to MODE, COND, DMAX, and SYM * as described below. * * Generate a matrix with the appropriate band structure, by one * of two methods: * * Method A: * Generate a dense M x N matrix by multiplying D on the left * and the right by random unitary matrices, then: * * Reduce the bandwidth according to KL and KU, using * Householder transformations. * * Method B: * Convert the bandwidth-0 (i.e., diagonal) matrix to a * bandwidth-1 matrix using Givens rotations, "chasing" * out-of-band elements back, much as in QR; then convert * the bandwidth-1 to a bandwidth-2 matrix, etc. Note * that for reasonably small bandwidths (relative to M and * N) this requires less storage, as a dense matrix is not * generated. Also, for hermitian or symmetric matrices, * only one triangle is generated. * * Method A is chosen if the bandwidth is a large fraction of the * order of the matrix, and LDA is at least M (so a dense * matrix can be stored.) Method B is chosen if the bandwidth * is small (< 1/2 N for hermitian or symmetric, < .3 N+M for * non-symmetric), or LDA is less than M and not less than the * bandwidth. * * Pack the matrix if desired. Options specified by PACK are: * no packing * zero out upper half (if hermitian) * zero out lower half (if hermitian) * store the upper half columnwise (if hermitian or upper * triangular) * store the lower half columnwise (if hermitian or lower * triangular) * store the lower triangle in banded format (if hermitian or * lower triangular) * store the upper triangle in banded format (if hermitian or * upper triangular) * store the entire matrix in banded format * If Method B is chosen, and band format is specified, then the * matrix will be generated in the band format, so no repacking * will be necessary. * * Arguments * ========= * * M - INTEGER * The number of rows of A. Not modified. * * N - INTEGER * The number of columns of A. N must equal M if the matrix * is symmetric or hermitian (i.e., if SYM is not 'N') * Not modified. * * DIST - CHARACTER*1 * On entry, DIST specifies the type of distribution to be used * to generate the random eigen-/singular values. * 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) * 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) * 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) * Not modified. * * ISEED - INTEGER array, dimension ( 4 ) * On entry ISEED specifies the seed of the random number * generator. They should lie between 0 and 4095 inclusive, * and ISEED(4) should be odd. The random number generator * uses a linear congruential sequence limited to small * integers, and so should produce machine independent * random numbers. The values of ISEED are changed on * exit, and can be used in the next call to CLATMS * to continue the same random number sequence. * Changed on exit. * * SYM - CHARACTER*1 * If SYM='H', the generated matrix is hermitian, with * eigenvalues specified by D, COND, MODE, and DMAX; they * may be positive, negative, or zero. * If SYM='P', the generated matrix is hermitian, with * eigenvalues (= singular values) specified by D, COND, * MODE, and DMAX; they will not be negative. * If SYM='N', the generated matrix is nonsymmetric, with * singular values specified by D, COND, MODE, and DMAX; * they will not be negative. * If SYM='S', the generated matrix is (complex) symmetric, * with singular values specified by D, COND, MODE, and * DMAX; they will not be negative. * Not modified. * * D - REAL array, dimension ( MIN( M, N ) ) * This array is used to specify the singular values or * eigenvalues of A (see SYM, above.) If MODE=0, then D is * assumed to contain the singular/eigenvalues, otherwise * they will be computed according to MODE, COND, and DMAX, * and placed in D. * Modified if MODE is nonzero. * * MODE - INTEGER * On entry this describes how the singular/eigenvalues are to * be specified: * MODE = 0 means use D as input * MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND * MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND * MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) * MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) * MODE = 5 sets D to random numbers in the range * ( 1/COND , 1 ) such that their logarithms * are uniformly distributed. * MODE = 6 set D to random numbers from same distribution * as the rest of the matrix. * MODE < 0 has the same meaning as ABS(MODE), except that * the order of the elements of D is reversed. * Thus if MODE is positive, D has entries ranging from * 1 to 1/COND, if negative, from 1/COND to 1, * If SYM='H', and MODE is neither 0, 6, nor -6, then * the elements of D will also be multiplied by a random * sign (i.e., +1 or -1.) * Not modified. * * COND - REAL * On entry, this is used as described under MODE above. * If used, it must be >= 1. Not modified. * * DMAX - REAL * If MODE is neither -6, 0 nor 6, the contents of D, as * computed according to MODE and COND, will be scaled by * DMAX / max(abs(D(i))); thus, the maximum absolute eigen- or * singular value (which is to say the norm) will be abs(DMAX). * Note that DMAX need not be positive: if DMAX is negative * (or zero), D will be scaled by a negative number (or zero). * Not modified. * * KL - INTEGER * This specifies the lower bandwidth of the matrix. For * example, KL=0 implies upper triangular, KL=1 implies upper * Hessenberg, and KL being at least M-1 means that the matrix * has full lower bandwidth. KL must equal KU if the matrix * is symmetric or hermitian. * Not modified. * * KU - INTEGER * This specifies the upper bandwidth of the matrix. For * example, KU=0 implies lower triangular, KU=1 implies lower * Hessenberg, and KU being at least N-1 means that the matrix * has full upper bandwidth. KL must equal KU if the matrix * is symmetric or hermitian. * Not modified. * * PACK - CHARACTER*1 * This specifies packing of matrix as follows: * 'N' => no packing * 'U' => zero out all subdiagonal entries (if symmetric * or hermitian) * 'L' => zero out all superdiagonal entries (if symmetric * or hermitian) * 'C' => store the upper triangle columnwise (only if the * matrix is symmetric, hermitian, or upper triangular) * 'R' => store the lower triangle columnwise (only if the * matrix is symmetric, hermitian, or lower triangular) * 'B' => store the lower triangle in band storage scheme * (only if the matrix is symmetric, hermitian, or * lower triangular) * 'Q' => store the upper triangle in band storage scheme * (only if the matrix is symmetric, hermitian, or * upper triangular) * 'Z' => store the entire matrix in band storage scheme * (pivoting can be provided for by using this * option to store A in the trailing rows of * the allocated storage) * * Using these options, the various LAPACK packed and banded * storage schemes can be obtained: * GB - use 'Z' * PB, SB, HB, or TB - use 'B' or 'Q' * PP, SP, HB, or TP - use 'C' or 'R' * * If two calls to CLATMS differ only in the PACK parameter, * they will generate mathematically equivalent matrices. * Not modified. * * A - COMPLEX array, dimension ( LDA, N ) * On exit A is the desired test matrix. A is first generated * in full (unpacked) form, and then packed, if so specified * by PACK. Thus, the first M elements of the first N * columns will always be modified. If PACK specifies a * packed or banded storage scheme, all LDA elements of the * first N columns will be modified; the elements of the * array which do not correspond to elements of the generated * matrix are set to zero. * Modified. * * LDA - INTEGER * LDA specifies the first dimension of A as declared in the * calling program. If PACK='N', 'U', 'L', 'C', or 'R', then * LDA must be at least M. If PACK='B' or 'Q', then LDA must * be at least MIN( KL, M-1) (which is equal to MIN(KU,N-1)). * If PACK='Z', LDA must be large enough to hold the packed * array: MIN( KU, N-1) + MIN( KL, M-1) + 1. * Not modified. * * WORK - COMPLEX array, dimension ( 3*MAX( N, M ) ) * Workspace. * Modified. * * INFO - INTEGER * Error code. On exit, INFO will be set to one of the * following values: * 0 => normal return * -1 => M negative or unequal to N and SYM='S', 'H', or 'P' * -2 => N negative * -3 => DIST illegal string * -5 => SYM illegal string * -7 => MODE not in range -6 to 6 * -8 => COND less than 1.0, and MODE neither -6, 0 nor 6 * -10 => KL negative * -11 => KU negative, or SYM is not 'N' and KU is not equal to * KL * -12 => PACK illegal string, or PACK='U' or 'L', and SYM='N'; * or PACK='C' or 'Q' and SYM='N' and KL is not zero; * or PACK='R' or 'B' and SYM='N' and KU is not zero; * or PACK='U', 'L', 'C', 'R', 'B', or 'Q', and M is not * N. * -14 => LDA is less than M, or PACK='Z' and LDA is less than * MIN(KU,N-1) + MIN(KL,M-1) + 1. * 1 => Error return from SLATM1 * 2 => Cannot scale to DMAX (max. sing. value is 0) * 3 => Error return from CLAGGE, CLAGHE or CLAGSY * * ===================================================================== * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E+0 ) REAL ONE PARAMETER ( ONE = 1.0E+0 ) COMPLEX CZERO PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) ) REAL TWOPI PARAMETER ( TWOPI = 6.2831853071795864769252867663E+0 ) * .. * .. Local Scalars .. LOGICAL CSYM, GIVENS, ILEXTR, ILTEMP, TOPDWN INTEGER I, IC, ICOL, IDIST, IENDCH, IINFO, IL, ILDA, $ IOFFG, IOFFST, IPACK, IPACKG, IR, IR1, IR2, $ IROW, IRSIGN, ISKEW, ISYM, ISYMPK, J, JC, JCH, $ JKL, JKU, JR, K, LLB, MINLDA, MNMIN, MR, NC, $ UUB REAL ALPHA, ANGLE, REALC, TEMP COMPLEX C, CT, CTEMP, DUMMY, EXTRA, S, ST * .. * .. External Functions .. LOGICAL LSAME REAL SLARND COMPLEX CLARND EXTERNAL LSAME, SLARND, CLARND * .. * .. External Subroutines .. EXTERNAL CLAGGE, CLAGHE, CLAGSY, CLAROT, CLARTG, CLASET, $ SLATM1, SSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, CMPLX, CONJG, COS, MAX, MIN, MOD, REAL, $ SIN * .. * .. Executable Statements .. * * 1) Decode and Test the input parameters. * Initialize flags & seed. * INFO = 0 * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * * Decode DIST * IF( LSAME( DIST, 'U' ) ) THEN IDIST = 1 ELSE IF( LSAME( DIST, 'S' ) ) THEN IDIST = 2 ELSE IF( LSAME( DIST, 'N' ) ) THEN IDIST = 3 ELSE IDIST = -1 END IF * * Decode SYM * IF( LSAME( SYM, 'N' ) ) THEN ISYM = 1 IRSIGN = 0 CSYM = .FALSE. ELSE IF( LSAME( SYM, 'P' ) ) THEN ISYM = 2 IRSIGN = 0 CSYM = .FALSE. ELSE IF( LSAME( SYM, 'S' ) ) THEN ISYM = 2 IRSIGN = 0 CSYM = .TRUE. ELSE IF( LSAME( SYM, 'H' ) ) THEN ISYM = 2 IRSIGN = 1 CSYM = .FALSE. ELSE ISYM = -1 END IF * * Decode PACK * ISYMPK = 0 IF( LSAME( PACK, 'N' ) ) THEN IPACK = 0 ELSE IF( LSAME( PACK, 'U' ) ) THEN IPACK = 1 ISYMPK = 1 ELSE IF( LSAME( PACK, 'L' ) ) THEN IPACK = 2 ISYMPK = 1 ELSE IF( LSAME( PACK, 'C' ) ) THEN IPACK = 3 ISYMPK = 2 ELSE IF( LSAME( PACK, 'R' ) ) THEN IPACK = 4 ISYMPK = 3 ELSE IF( LSAME( PACK, 'B' ) ) THEN IPACK = 5 ISYMPK = 3 ELSE IF( LSAME( PACK, 'Q' ) ) THEN IPACK = 6 ISYMPK = 2 ELSE IF( LSAME( PACK, 'Z' ) ) THEN IPACK = 7 ELSE IPACK = -1 END IF * * Set certain internal parameters * MNMIN = MIN( M, N ) LLB = MIN( KL, M-1 ) UUB = MIN( KU, N-1 ) MR = MIN( M, N+LLB ) NC = MIN( N, M+UUB ) * IF( IPACK.EQ.5 .OR. IPACK.EQ.6 ) THEN MINLDA = UUB + 1 ELSE IF( IPACK.EQ.7 ) THEN MINLDA = LLB + UUB + 1 ELSE MINLDA = M END IF * * Use Givens rotation method if bandwidth small enough, * or if LDA is too small to store the matrix unpacked. * GIVENS = .FALSE. IF( ISYM.EQ.1 ) THEN IF( REAL( LLB+UUB ).LT.0.3*REAL( MAX( 1, MR+NC ) ) ) $ GIVENS = .TRUE. ELSE IF( 2*LLB.LT.M ) $ GIVENS = .TRUE. END IF IF( LDA.LT.M .AND. LDA.GE.MINLDA ) $ GIVENS = .TRUE. * * Set INFO if an error * IF( M.LT.0 ) THEN INFO = -1 ELSE IF( M.NE.N .AND. ISYM.NE.1 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( IDIST.EQ.-1 ) THEN INFO = -3 ELSE IF( ISYM.EQ.-1 ) THEN INFO = -5 ELSE IF( ABS( MODE ).GT.6 ) THEN INFO = -7 ELSE IF( ( MODE.NE.0 .AND. ABS( MODE ).NE.6 ) .AND. COND.LT.ONE ) $ THEN INFO = -8 ELSE IF( KL.LT.0 ) THEN INFO = -10 ELSE IF( KU.LT.0 .OR. ( ISYM.NE.1 .AND. KL.NE.KU ) ) THEN INFO = -11 ELSE IF( IPACK.EQ.-1 .OR. ( ISYMPK.EQ.1 .AND. ISYM.EQ.1 ) .OR. $ ( ISYMPK.EQ.2 .AND. ISYM.EQ.1 .AND. KL.GT.0 ) .OR. $ ( ISYMPK.EQ.3 .AND. ISYM.EQ.1 .AND. KU.GT.0 ) .OR. $ ( ISYMPK.NE.0 .AND. M.NE.N ) ) THEN INFO = -12 ELSE IF( LDA.LT.MAX( 1, MINLDA ) ) THEN INFO = -14 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'CLATMS', -INFO ) RETURN END IF * * Initialize random number generator * DO 10 I = 1, 4 ISEED( I ) = MOD( ABS( ISEED( I ) ), 4096 ) 10 CONTINUE * IF( MOD( ISEED( 4 ), 2 ).NE.1 ) $ ISEED( 4 ) = ISEED( 4 ) + 1 * * 2) Set up D if indicated. * * Compute D according to COND and MODE * CALL SLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, MNMIN, IINFO ) IF( IINFO.NE.0 ) THEN INFO = 1 RETURN END IF * * Choose Top-Down if D is (apparently) increasing, * Bottom-Up if D is (apparently) decreasing. * IF( ABS( D( 1 ) ).LE.ABS( D( MNMIN ) ) ) THEN TOPDWN = .TRUE. ELSE TOPDWN = .FALSE. END IF * IF( MODE.NE.0 .AND. ABS( MODE ).NE.6 ) THEN * * Scale by DMAX * TEMP = ABS( D( 1 ) ) DO 20 I = 2, MNMIN TEMP = MAX( TEMP, ABS( D( I ) ) ) 20 CONTINUE * IF( TEMP.GT.ZERO ) THEN ALPHA = DMAX / TEMP ELSE INFO = 2 RETURN END IF * CALL SSCAL( MNMIN, ALPHA, D, 1 ) * END IF * CALL CLASET( 'Full', LDA, N, CZERO, CZERO, A, LDA ) * * 3) Generate Banded Matrix using Givens rotations. * Also the special case of UUB=LLB=0 * * Compute Addressing constants to cover all * storage formats. Whether GE, HE, SY, GB, HB, or SB, * upper or lower triangle or both, * the (i,j)-th element is in * A( i - ISKEW*j + IOFFST, j ) * IF( IPACK.GT.4 ) THEN ILDA = LDA - 1 ISKEW = 1 IF( IPACK.GT.5 ) THEN IOFFST = UUB + 1 ELSE IOFFST = 1 END IF ELSE ILDA = LDA ISKEW = 0 IOFFST = 0 END IF * * IPACKG is the format that the matrix is generated in. If this is * different from IPACK, then the matrix must be repacked at the * end. It also signals how to compute the norm, for scaling. * IPACKG = 0 * * Diagonal Matrix -- We are done, unless it * is to be stored HP/SP/PP/TP (PACK='R' or 'C') * IF( LLB.EQ.0 .AND. UUB.EQ.0 ) THEN DO 30 J = 1, MNMIN A( ( 1-ISKEW )*J+IOFFST, J ) = CMPLX( D( J ) ) 30 CONTINUE * IF( IPACK.LE.2 .OR. IPACK.GE.5 ) $ IPACKG = IPACK * ELSE IF( GIVENS ) THEN * * Check whether to use Givens rotations, * Householder transformations, or nothing. * IF( ISYM.EQ.1 ) THEN * * Non-symmetric -- A = U D V * IF( IPACK.GT.4 ) THEN IPACKG = IPACK ELSE IPACKG = 0 END IF * DO 40 J = 1, MNMIN A( ( 1-ISKEW )*J+IOFFST, J ) = CMPLX( D( J ) ) 40 CONTINUE * IF( TOPDWN ) THEN JKL = 0 DO 70 JKU = 1, UUB * * Transform from bandwidth JKL, JKU-1 to JKL, JKU * * Last row actually rotated is M * Last column actually rotated is MIN( M+JKU, N ) * DO 60 JR = 1, MIN( M+JKU, N ) + JKL - 1 EXTRA = CZERO ANGLE = TWOPI*SLARND( 1, ISEED ) C = COS( ANGLE )*CLARND( 5, ISEED ) S = SIN( ANGLE )*CLARND( 5, ISEED ) ICOL = MAX( 1, JR-JKL ) IF( JR.LT.M ) THEN IL = MIN( N, JR+JKU ) + 1 - ICOL CALL CLAROT( .TRUE., JR.GT.JKL, .FALSE., IL, C, $ S, A( JR-ISKEW*ICOL+IOFFST, ICOL ), $ ILDA, EXTRA, DUMMY ) END IF * * Chase "EXTRA" back up * IR = JR IC = ICOL DO 50 JCH = JR - JKL, 1, -JKL - JKU IF( IR.LT.M ) THEN CALL CLARTG( A( IR+1-ISKEW*( IC+1 )+IOFFST, $ IC+1 ), EXTRA, REALC, S, DUMMY ) DUMMY = CLARND( 5, ISEED ) C = CONJG( REALC*DUMMY ) S = CONJG( -S*DUMMY ) END IF IROW = MAX( 1, JCH-JKU ) IL = IR + 2 - IROW CTEMP = CZERO ILTEMP = JCH.GT.JKU CALL CLAROT( .FALSE., ILTEMP, .TRUE., IL, C, S, $ A( IROW-ISKEW*IC+IOFFST, IC ), $ ILDA, CTEMP, EXTRA ) IF( ILTEMP ) THEN CALL CLARTG( A( IROW+1-ISKEW*( IC+1 )+IOFFST, $ IC+1 ), CTEMP, REALC, S, DUMMY ) DUMMY = CLARND( 5, ISEED ) C = CONJG( REALC*DUMMY ) S = CONJG( -S*DUMMY ) * ICOL = MAX( 1, JCH-JKU-JKL ) IL = IC + 2 - ICOL EXTRA = CZERO CALL CLAROT( .TRUE., JCH.GT.JKU+JKL, .TRUE., $ IL, C, S, A( IROW-ISKEW*ICOL+ $ IOFFST, ICOL ), ILDA, EXTRA, $ CTEMP ) IC = ICOL IR = IROW END IF 50 CONTINUE 60 CONTINUE 70 CONTINUE * JKU = UUB DO 100 JKL = 1, LLB * * Transform from bandwidth JKL-1, JKU to JKL, JKU * DO 90 JC = 1, MIN( N+JKL, M ) + JKU - 1 EXTRA = CZERO ANGLE = TWOPI*SLARND( 1, ISEED ) C = COS( ANGLE )*CLARND( 5, ISEED ) S = SIN( ANGLE )*CLARND( 5, ISEED ) IROW = MAX( 1, JC-JKU ) IF( JC.LT.N ) THEN IL = MIN( M, JC+JKL ) + 1 - IROW CALL CLAROT( .FALSE., JC.GT.JKU, .FALSE., IL, C, $ S, A( IROW-ISKEW*JC+IOFFST, JC ), $ ILDA, EXTRA, DUMMY ) END IF * * Chase "EXTRA" back up * IC = JC IR = IROW DO 80 JCH = JC - JKU, 1, -JKL - JKU IF( IC.LT.N ) THEN CALL CLARTG( A( IR+1-ISKEW*( IC+1 )+IOFFST, $ IC+1 ), EXTRA, REALC, S, DUMMY ) DUMMY = CLARND( 5, ISEED ) C = CONJG( REALC*DUMMY ) S = CONJG( -S*DUMMY ) END IF ICOL = MAX( 1, JCH-JKL ) IL = IC + 2 - ICOL CTEMP = CZERO ILTEMP = JCH.GT.JKL CALL CLAROT( .TRUE., ILTEMP, .TRUE., IL, C, S, $ A( IR-ISKEW*ICOL+IOFFST, ICOL ), $ ILDA, CTEMP, EXTRA ) IF( ILTEMP ) THEN CALL CLARTG( A( IR+1-ISKEW*( ICOL+1 )+IOFFST, $ ICOL+1 ), CTEMP, REALC, S, $ DUMMY ) DUMMY = CLARND( 5, ISEED ) C = CONJG( REALC*DUMMY ) S = CONJG( -S*DUMMY ) IROW = MAX( 1, JCH-JKL-JKU ) IL = IR + 2 - IROW EXTRA = CZERO CALL CLAROT( .FALSE., JCH.GT.JKL+JKU, .TRUE., $ IL, C, S, A( IROW-ISKEW*ICOL+ $ IOFFST, ICOL ), ILDA, EXTRA, $ CTEMP ) IC = ICOL IR = IROW END IF 80 CONTINUE 90 CONTINUE 100 CONTINUE * ELSE * * Bottom-Up -- Start at the bottom right. * JKL = 0 DO 130 JKU = 1, UUB * * Transform from bandwidth JKL, JKU-1 to JKL, JKU * * First row actually rotated is M * First column actually rotated is MIN( M+JKU, N ) * IENDCH = MIN( M, N+JKL ) - 1 DO 120 JC = MIN( M+JKU, N ) - 1, 1 - JKL, -1 EXTRA = CZERO ANGLE = TWOPI*SLARND( 1, ISEED ) C = COS( ANGLE )*CLARND( 5, ISEED ) S = SIN( ANGLE )*CLARND( 5, ISEED ) IROW = MAX( 1, JC-JKU+1 ) IF( JC.GT.0 ) THEN IL = MIN( M, JC+JKL+1 ) + 1 - IROW CALL CLAROT( .FALSE., .FALSE., JC+JKL.LT.M, IL, $ C, S, A( IROW-ISKEW*JC+IOFFST, $ JC ), ILDA, DUMMY, EXTRA ) END IF * * Chase "EXTRA" back down * IC = JC DO 110 JCH = JC + JKL, IENDCH, JKL + JKU ILEXTR = IC.GT.0 IF( ILEXTR ) THEN CALL CLARTG( A( JCH-ISKEW*IC+IOFFST, IC ), $ EXTRA, REALC, S, DUMMY ) DUMMY = CLARND( 5, ISEED ) C = REALC*DUMMY S = S*DUMMY END IF IC = MAX( 1, IC ) ICOL = MIN( N-1, JCH+JKU ) ILTEMP = JCH + JKU.LT.N CTEMP = CZERO CALL CLAROT( .TRUE., ILEXTR, ILTEMP, ICOL+2-IC, $ C, S, A( JCH-ISKEW*IC+IOFFST, IC ), $ ILDA, EXTRA, CTEMP ) IF( ILTEMP ) THEN CALL CLARTG( A( JCH-ISKEW*ICOL+IOFFST, $ ICOL ), CTEMP, REALC, S, DUMMY ) DUMMY = CLARND( 5, ISEED ) C = REALC*DUMMY S = S*DUMMY IL = MIN( IENDCH, JCH+JKL+JKU ) + 2 - JCH EXTRA = CZERO CALL CLAROT( .FALSE., .TRUE., $ JCH+JKL+JKU.LE.IENDCH, IL, C, S, $ A( JCH-ISKEW*ICOL+IOFFST, $ ICOL ), ILDA, CTEMP, EXTRA ) IC = ICOL END IF 110 CONTINUE 120 CONTINUE 130 CONTINUE * JKU = UUB DO 160 JKL = 1, LLB * * Transform from bandwidth JKL-1, JKU to JKL, JKU * * First row actually rotated is MIN( N+JKL, M ) * First column actually rotated is N * IENDCH = MIN( N, M+JKU ) - 1 DO 150 JR = MIN( N+JKL, M ) - 1, 1 - JKU, -1 EXTRA = CZERO ANGLE = TWOPI*SLARND( 1, ISEED ) C = COS( ANGLE )*CLARND( 5, ISEED ) S = SIN( ANGLE )*CLARND( 5, ISEED ) ICOL = MAX( 1, JR-JKL+1 ) IF( JR.GT.0 ) THEN IL = MIN( N, JR+JKU+1 ) + 1 - ICOL CALL CLAROT( .TRUE., .FALSE., JR+JKU.LT.N, IL, $ C, S, A( JR-ISKEW*ICOL+IOFFST, $ ICOL ), ILDA, DUMMY, EXTRA ) END IF * * Chase "EXTRA" back down * IR = JR DO 140 JCH = JR + JKU, IENDCH, JKL + JKU ILEXTR = IR.GT.0 IF( ILEXTR ) THEN CALL CLARTG( A( IR-ISKEW*JCH+IOFFST, JCH ), $ EXTRA, REALC, S, DUMMY ) DUMMY = CLARND( 5, ISEED ) C = REALC*DUMMY S = S*DUMMY END IF IR = MAX( 1, IR ) IROW = MIN( M-1, JCH+JKL ) ILTEMP = JCH + JKL.LT.M CTEMP = CZERO CALL CLAROT( .FALSE., ILEXTR, ILTEMP, IROW+2-IR, $ C, S, A( IR-ISKEW*JCH+IOFFST, $ JCH ), ILDA, EXTRA, CTEMP ) IF( ILTEMP ) THEN CALL CLARTG( A( IROW-ISKEW*JCH+IOFFST, JCH ), $ CTEMP, REALC, S, DUMMY ) DUMMY = CLARND( 5, ISEED ) C = REALC*DUMMY S = S*DUMMY IL = MIN( IENDCH, JCH+JKL+JKU ) + 2 - JCH EXTRA = CZERO CALL CLAROT( .TRUE., .TRUE., $ JCH+JKL+JKU.LE.IENDCH, IL, C, S, $ A( IROW-ISKEW*JCH+IOFFST, JCH ), $ ILDA, CTEMP, EXTRA ) IR = IROW END IF 140 CONTINUE 150 CONTINUE 160 CONTINUE * END IF * ELSE * * Symmetric -- A = U D U' * Hermitian -- A = U D U* * IPACKG = IPACK IOFFG = IOFFST * IF( TOPDWN ) THEN * * Top-Down -- Generate Upper triangle only * IF( IPACK.GE.5 ) THEN IPACKG = 6 IOFFG = UUB + 1 ELSE IPACKG = 1 END IF * DO 170 J = 1, MNMIN A( ( 1-ISKEW )*J+IOFFG, J ) = CMPLX( D( J ) ) 170 CONTINUE * DO 200 K = 1, UUB DO 190 JC = 1, N - 1 IROW = MAX( 1, JC-K ) IL = MIN( JC+1, K+2 ) EXTRA = CZERO CTEMP = A( JC-ISKEW*( JC+1 )+IOFFG, JC+1 ) ANGLE = TWOPI*SLARND( 1, ISEED ) C = COS( ANGLE )*CLARND( 5, ISEED ) S = SIN( ANGLE )*CLARND( 5, ISEED ) IF( CSYM ) THEN CT = C ST = S ELSE CTEMP = CONJG( CTEMP ) CT = CONJG( C ) ST = CONJG( S ) END IF CALL CLAROT( .FALSE., JC.GT.K, .TRUE., IL, C, S, $ A( IROW-ISKEW*JC+IOFFG, JC ), ILDA, $ EXTRA, CTEMP ) CALL CLAROT( .TRUE., .TRUE., .FALSE., $ MIN( K, N-JC )+1, CT, ST, $ A( ( 1-ISKEW )*JC+IOFFG, JC ), ILDA, $ CTEMP, DUMMY ) * * Chase EXTRA back up the matrix * ICOL = JC DO 180 JCH = JC - K, 1, -K CALL CLARTG( A( JCH+1-ISKEW*( ICOL+1 )+IOFFG, $ ICOL+1 ), EXTRA, REALC, S, DUMMY ) DUMMY = CLARND( 5, ISEED ) C = CONJG( REALC*DUMMY ) S = CONJG( -S*DUMMY ) CTEMP = A( JCH-ISKEW*( JCH+1 )+IOFFG, JCH+1 ) IF( CSYM ) THEN CT = C ST = S ELSE CTEMP = CONJG( CTEMP ) CT = CONJG( C ) ST = CONJG( S ) END IF CALL CLAROT( .TRUE., .TRUE., .TRUE., K+2, C, S, $ A( ( 1-ISKEW )*JCH+IOFFG, JCH ), $ ILDA, CTEMP, EXTRA ) IROW = MAX( 1, JCH-K ) IL = MIN( JCH+1, K+2 ) EXTRA = CZERO CALL CLAROT( .FALSE., JCH.GT.K, .TRUE., IL, CT, $ ST, A( IROW-ISKEW*JCH+IOFFG, JCH ), $ ILDA, EXTRA, CTEMP ) ICOL = JCH 180 CONTINUE 190 CONTINUE 200 CONTINUE * * If we need lower triangle, copy from upper. Note that * the order of copying is chosen to work for 'q' -> 'b' * IF( IPACK.NE.IPACKG .AND. IPACK.NE.3 ) THEN DO 230 JC = 1, N IROW = IOFFST - ISKEW*JC IF( CSYM ) THEN DO 210 JR = JC, MIN( N, JC+UUB ) A( JR+IROW, JC ) = A( JC-ISKEW*JR+IOFFG, JR ) 210 CONTINUE ELSE DO 220 JR = JC, MIN( N, JC+UUB ) A( JR+IROW, JC ) = CONJG( A( JC-ISKEW*JR+ $ IOFFG, JR ) ) 220 CONTINUE END IF 230 CONTINUE IF( IPACK.EQ.5 ) THEN DO 250 JC = N - UUB + 1, N DO 240 JR = N + 2 - JC, UUB + 1 A( JR, JC ) = CZERO 240 CONTINUE 250 CONTINUE END IF IF( IPACKG.EQ.6 ) THEN IPACKG = IPACK ELSE IPACKG = 0 END IF END IF ELSE * * Bottom-Up -- Generate Lower triangle only * IF( IPACK.GE.5 ) THEN IPACKG = 5 IF( IPACK.EQ.6 ) $ IOFFG = 1 ELSE IPACKG = 2 END IF * DO 260 J = 1, MNMIN A( ( 1-ISKEW )*J+IOFFG, J ) = CMPLX( D( J ) ) 260 CONTINUE * DO 290 K = 1, UUB DO 280 JC = N - 1, 1, -1 IL = MIN( N+1-JC, K+2 ) EXTRA = CZERO CTEMP = A( 1+( 1-ISKEW )*JC+IOFFG, JC ) ANGLE = TWOPI*SLARND( 1, ISEED ) C = COS( ANGLE )*CLARND( 5, ISEED ) S = SIN( ANGLE )*CLARND( 5, ISEED ) IF( CSYM ) THEN CT = C ST = S ELSE CTEMP = CONJG( CTEMP ) CT = CONJG( C ) ST = CONJG( S ) END IF CALL CLAROT( .FALSE., .TRUE., N-JC.GT.K, IL, C, S, $ A( ( 1-ISKEW )*JC+IOFFG, JC ), ILDA, $ CTEMP, EXTRA ) ICOL = MAX( 1, JC-K+1 ) CALL CLAROT( .TRUE., .FALSE., .TRUE., JC+2-ICOL, $ CT, ST, A( JC-ISKEW*ICOL+IOFFG, $ ICOL ), ILDA, DUMMY, CTEMP ) * * Chase EXTRA back down the matrix * ICOL = JC DO 270 JCH = JC + K, N - 1, K CALL CLARTG( A( JCH-ISKEW*ICOL+IOFFG, ICOL ), $ EXTRA, REALC, S, DUMMY ) DUMMY = CLARND( 5, ISEED ) C = REALC*DUMMY S = S*DUMMY CTEMP = A( 1+( 1-ISKEW )*JCH+IOFFG, JCH ) IF( CSYM ) THEN CT = C ST = S ELSE CTEMP = CONJG( CTEMP ) CT = CONJG( C ) ST = CONJG( S ) END IF CALL CLAROT( .TRUE., .TRUE., .TRUE., K+2, C, S, $ A( JCH-ISKEW*ICOL+IOFFG, ICOL ), $ ILDA, EXTRA, CTEMP ) IL = MIN( N+1-JCH, K+2 ) EXTRA = CZERO CALL CLAROT( .FALSE., .TRUE., N-JCH.GT.K, IL, $ CT, ST, A( ( 1-ISKEW )*JCH+IOFFG, $ JCH ), ILDA, CTEMP, EXTRA ) ICOL = JCH 270 CONTINUE 280 CONTINUE 290 CONTINUE * * If we need upper triangle, copy from lower. Note that * the order of copying is chosen to work for 'b' -> 'q' * IF( IPACK.NE.IPACKG .AND. IPACK.NE.4 ) THEN DO 320 JC = N, 1, -1 IROW = IOFFST - ISKEW*JC IF( CSYM ) THEN DO 300 JR = JC, MAX( 1, JC-UUB ), -1 A( JR+IROW, JC ) = A( JC-ISKEW*JR+IOFFG, JR ) 300 CONTINUE ELSE DO 310 JR = JC, MAX( 1, JC-UUB ), -1 A( JR+IROW, JC ) = CONJG( A( JC-ISKEW*JR+ $ IOFFG, JR ) ) 310 CONTINUE END IF 320 CONTINUE IF( IPACK.EQ.6 ) THEN DO 340 JC = 1, UUB DO 330 JR = 1, UUB + 1 - JC A( JR, JC ) = CZERO 330 CONTINUE 340 CONTINUE END IF IF( IPACKG.EQ.5 ) THEN IPACKG = IPACK ELSE IPACKG = 0 END IF END IF END IF * * Ensure that the diagonal is real if Hermitian * IF( .NOT.CSYM ) THEN DO 350 JC = 1, N IROW = IOFFST + ( 1-ISKEW )*JC A( IROW, JC ) = CMPLX( REAL( A( IROW, JC ) ) ) 350 CONTINUE END IF * END IF * ELSE * * 4) Generate Banded Matrix by first * Rotating by random Unitary matrices, * then reducing the bandwidth using Householder * transformations. * * Note: we should get here only if LDA .ge. N * IF( ISYM.EQ.1 ) THEN * * Non-symmetric -- A = U D V * CALL CLAGGE( MR, NC, LLB, UUB, D, A, LDA, ISEED, WORK, $ IINFO ) ELSE * * Symmetric -- A = U D U' or * Hermitian -- A = U D U* * IF( CSYM ) THEN CALL CLAGSY( M, LLB, D, A, LDA, ISEED, WORK, IINFO ) ELSE CALL CLAGHE( M, LLB, D, A, LDA, ISEED, WORK, IINFO ) END IF END IF * IF( IINFO.NE.0 ) THEN INFO = 3 RETURN END IF END IF * * 5) Pack the matrix * IF( IPACK.NE.IPACKG ) THEN IF( IPACK.EQ.1 ) THEN * * 'U' -- Upper triangular, not packed * DO 370 J = 1, M DO 360 I = J + 1, M A( I, J ) = CZERO 360 CONTINUE 370 CONTINUE * ELSE IF( IPACK.EQ.2 ) THEN * * 'L' -- Lower triangular, not packed * DO 390 J = 2, M DO 380 I = 1, J - 1 A( I, J ) = CZERO 380 CONTINUE 390 CONTINUE * ELSE IF( IPACK.EQ.3 ) THEN * * 'C' -- Upper triangle packed Columnwise. * ICOL = 1 IROW = 0 DO 410 J = 1, M DO 400 I = 1, J IROW = IROW + 1 IF( IROW.GT.LDA ) THEN IROW = 1 ICOL = ICOL + 1 END IF A( IROW, ICOL ) = A( I, J ) 400 CONTINUE 410 CONTINUE * ELSE IF( IPACK.EQ.4 ) THEN * * 'R' -- Lower triangle packed Columnwise. * ICOL = 1 IROW = 0 DO 430 J = 1, M DO 420 I = J, M IROW = IROW + 1 IF( IROW.GT.LDA ) THEN IROW = 1 ICOL = ICOL + 1 END IF A( IROW, ICOL ) = A( I, J ) 420 CONTINUE 430 CONTINUE * ELSE IF( IPACK.GE.5 ) THEN * * 'B' -- The lower triangle is packed as a band matrix. * 'Q' -- The upper triangle is packed as a band matrix. * 'Z' -- The whole matrix is packed as a band matrix. * IF( IPACK.EQ.5 ) $ UUB = 0 IF( IPACK.EQ.6 ) $ LLB = 0 * DO 450 J = 1, UUB DO 440 I = MIN( J+LLB, M ), 1, -1 A( I-J+UUB+1, J ) = A( I, J ) 440 CONTINUE 450 CONTINUE * DO 470 J = UUB + 2, N DO 460 I = J - UUB, MIN( J+LLB, M ) A( I-J+UUB+1, J ) = A( I, J ) 460 CONTINUE 470 CONTINUE END IF * * If packed, zero out extraneous elements. * * Symmetric/Triangular Packed -- * zero out everything after A(IROW,ICOL) * IF( IPACK.EQ.3 .OR. IPACK.EQ.4 ) THEN DO 490 JC = ICOL, M DO 480 JR = IROW + 1, LDA A( JR, JC ) = CZERO 480 CONTINUE IROW = 0 490 CONTINUE * ELSE IF( IPACK.GE.5 ) THEN * * Packed Band -- * 1st row is now in A( UUB+2-j, j), zero above it * m-th row is now in A( M+UUB-j,j), zero below it * last non-zero diagonal is now in A( UUB+LLB+1,j ), * zero below it, too. * IR1 = UUB + LLB + 2 IR2 = UUB + M + 2 DO 520 JC = 1, N DO 500 JR = 1, UUB + 1 - JC A( JR, JC ) = CZERO 500 CONTINUE DO 510 JR = MAX( 1, MIN( IR1, IR2-JC ) ), LDA A( JR, JC ) = CZERO 510 CONTINUE 520 CONTINUE END IF END IF * RETURN * * End of CLATMS * END SHAR_EOF fi # end of overwriting check if test -f 'dlagge.f' then echo shar: will not over-write existing file "'dlagge.f'" else cat << SHAR_EOF > 'dlagge.f' SUBROUTINE DLAGGE( M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO ) * * -- LAPACK auxiliary test routine (version 2.0) * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDA, M, N * .. * .. Array Arguments .. INTEGER ISEED( 4 ) DOUBLE PRECISION A( LDA, * ), D( * ), WORK( * ) * .. * * Purpose * ======= * * DLAGGE generates a real general m by n matrix A, by pre- and post- * multiplying a real diagonal matrix D with random orthogonal matrices: * A = U*D*V. The lower and upper bandwidths may then be reduced to * kl and ku by additional orthogonal transformations. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * * KL (input) INTEGER * The number of nonzero subdiagonals within the band of A. * 0 <= KL <= M-1. * * KU (input) INTEGER * The number of nonzero superdiagonals within the band of A. * 0 <= KU <= N-1. * * D (input) DOUBLE PRECISION array, dimension (min(M,N)) * The diagonal elements of the diagonal matrix D. * * A (output) DOUBLE PRECISION array, dimension (LDA,N) * The generated m by n matrix A. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= M. * * ISEED (input/output) INTEGER array, dimension (4) * On entry, the seed of the random number generator; the array * elements must be between 0 and 4095, and ISEED(4) must be * odd. * On exit, the seed is updated. * * WORK (workspace) DOUBLE PRECISION array, dimension (M+N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J DOUBLE PRECISION TAU, WA, WB, WN * .. * .. External Subroutines .. EXTERNAL DGEMV, DGER, DLARNV, DSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN, SIGN * .. * .. External Functions .. DOUBLE PRECISION DNRM2 EXTERNAL DNRM2 * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( KL.LT.0 .OR. KL.GT.M-1 ) THEN INFO = -3 ELSE IF( KU.LT.0 .OR. KU.GT.N-1 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -7 END IF IF( INFO.LT.0 ) THEN CALL XERBLA( 'DLAGGE', -INFO ) RETURN END IF * * initialize A to diagonal matrix * DO 20 J = 1, N DO 10 I = 1, M A( I, J ) = ZERO 10 CONTINUE 20 CONTINUE DO 30 I = 1, MIN( M, N ) A( I, I ) = D( I ) 30 CONTINUE * * pre- and post-multiply A by random orthogonal matrices * DO 40 I = MIN( M, N ), 1, -1 IF( I.LT.M ) THEN * * generate random reflection * CALL DLARNV( 3, ISEED, M-I+1, WORK ) WN = DNRM2( M-I+1, WORK, 1 ) WA = SIGN( WN, WORK( 1 ) ) IF( WN.EQ.ZERO ) THEN TAU = ZERO ELSE WB = WORK( 1 ) + WA CALL DSCAL( M-I, ONE / WB, WORK( 2 ), 1 ) WORK( 1 ) = ONE TAU = WB / WA END IF * * multiply A(i:m,i:n) by random reflection from the left * CALL DGEMV( 'Transpose', M-I+1, N-I+1, ONE, A( I, I ), LDA, $ WORK, 1, ZERO, WORK( M+1 ), 1 ) CALL DGER( M-I+1, N-I+1, -TAU, WORK, 1, WORK( M+1 ), 1, $ A( I, I ), LDA ) END IF IF( I.LT.N ) THEN * * generate random reflection * CALL DLARNV( 3, ISEED, N-I+1, WORK ) WN = DNRM2( N-I+1, WORK, 1 ) WA = SIGN( WN, WORK( 1 ) ) IF( WN.EQ.ZERO ) THEN TAU = ZERO ELSE WB = WORK( 1 ) + WA CALL DSCAL( N-I, ONE / WB, WORK( 2 ), 1 ) WORK( 1 ) = ONE TAU = WB / WA END IF * * multiply A(i:m,i:n) by random reflection from the right * CALL DGEMV( 'No transpose', M-I+1, N-I+1, ONE, A( I, I ), $ LDA, WORK, 1, ZERO, WORK( N+1 ), 1 ) CALL DGER( M-I+1, N-I+1, -TAU, WORK( N+1 ), 1, WORK, 1, $ A( I, I ), LDA ) END IF 40 CONTINUE * * Reduce number of subdiagonals to KL and number of superdiagonals * to KU * DO 70 I = 1, MAX( M-1-KL, N-1-KU ) IF( KL.LE.KU ) THEN * * annihilate subdiagonal elements first (necessary if KL = 0) * IF( I.LE.MIN( M-1-KL, N ) ) THEN * * generate reflection to annihilate A(kl+i+1:m,i) * WN = DNRM2( M-KL-I+1, A( KL+I, I ), 1 ) WA = SIGN( WN, A( KL+I, I ) ) IF( WN.EQ.ZERO ) THEN TAU = ZERO ELSE WB = A( KL+I, I ) + WA CALL DSCAL( M-KL-I, ONE / WB, A( KL+I+1, I ), 1 ) A( KL+I, I ) = ONE TAU = WB / WA END IF * * apply reflection to A(kl+i:m,i+1:n) from the left * CALL DGEMV( 'Transpose', M-KL-I+1, N-I, ONE, $ A( KL+I, I+1 ), LDA, A( KL+I, I ), 1, ZERO, $ WORK, 1 ) CALL DGER( M-KL-I+1, N-I, -TAU, A( KL+I, I ), 1, WORK, 1, $ A( KL+I, I+1 ), LDA ) A( KL+I, I ) = -WA END IF * IF( I.LE.MIN( N-1-KU, M ) ) THEN * * generate reflection to annihilate A(i,ku+i+1:n) * WN = DNRM2( N-KU-I+1, A( I, KU+I ), LDA ) WA = SIGN( WN, A( I, KU+I ) ) IF( WN.EQ.ZERO ) THEN TAU = ZERO ELSE WB = A( I, KU+I ) + WA CALL DSCAL( N-KU-I, ONE / WB, A( I, KU+I+1 ), LDA ) A( I, KU+I ) = ONE TAU = WB / WA END IF * * apply reflection to A(i+1:m,ku+i:n) from the right * CALL DGEMV( 'No transpose', M-I, N-KU-I+1, ONE, $ A( I+1, KU+I ), LDA, A( I, KU+I ), LDA, ZERO, $ WORK, 1 ) CALL DGER( M-I, N-KU-I+1, -TAU, WORK, 1, A( I, KU+I ), $ LDA, A( I+1, KU+I ), LDA ) A( I, KU+I ) = -WA END IF ELSE * * annihilate superdiagonal elements first (necessary if * KU = 0) * IF( I.LE.MIN( N-1-KU, M ) ) THEN * * generate reflection to annihilate A(i,ku+i+1:n) * WN = DNRM2( N-KU-I+1, A( I, KU+I ), LDA ) WA = SIGN( WN, A( I, KU+I ) ) IF( WN.EQ.ZERO ) THEN TAU = ZERO ELSE WB = A( I, KU+I ) + WA CALL DSCAL( N-KU-I, ONE / WB, A( I, KU+I+1 ), LDA ) A( I, KU+I ) = ONE TAU = WB / WA END IF * * apply reflection to A(i+1:m,ku+i:n) from the right * CALL DGEMV( 'No transpose', M-I, N-KU-I+1, ONE, $ A( I+1, KU+I ), LDA, A( I, KU+I ), LDA, ZERO, $ WORK, 1 ) CALL DGER( M-I, N-KU-I+1, -TAU, WORK, 1, A( I, KU+I ), $ LDA, A( I+1, KU+I ), LDA ) A( I, KU+I ) = -WA END IF * IF( I.LE.MIN( M-1-KL, N ) ) THEN * * generate reflection to annihilate A(kl+i+1:m,i) * WN = DNRM2( M-KL-I+1, A( KL+I, I ), 1 ) WA = SIGN( WN, A( KL+I, I ) ) IF( WN.EQ.ZERO ) THEN TAU = ZERO ELSE WB = A( KL+I, I ) + WA CALL DSCAL( M-KL-I, ONE / WB, A( KL+I+1, I ), 1 ) A( KL+I, I ) = ONE TAU = WB / WA END IF * * apply reflection to A(kl+i:m,i+1:n) from the left * CALL DGEMV( 'Transpose', M-KL-I+1, N-I, ONE, $ A( KL+I, I+1 ), LDA, A( KL+I, I ), 1, ZERO, $ WORK, 1 ) CALL DGER( M-KL-I+1, N-I, -TAU, A( KL+I, I ), 1, WORK, 1, $ A( KL+I, I+1 ), LDA ) A( KL+I, I ) = -WA END IF END IF * DO 50 J = KL + I + 1, M A( J, I ) = ZERO 50 CONTINUE * DO 60 J = KU + I + 1, N A( I, J ) = ZERO 60 CONTINUE 70 CONTINUE RETURN * * End of DLAGGE * END SHAR_EOF fi # end of overwriting check if test -f 'dlagsy.f' then echo shar: will not over-write existing file "'dlagsy.f'" else cat << SHAR_EOF > 'dlagsy.f' SUBROUTINE DLAGSY( N, K, D, A, LDA, ISEED, WORK, INFO ) * * -- LAPACK auxiliary test routine (version 2.0) * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, N * .. * .. Array Arguments .. INTEGER ISEED( 4 ) DOUBLE PRECISION A( LDA, * ), D( * ), WORK( * ) * .. * * Purpose * ======= * * DLAGSY generates a real symmetric matrix A, by pre- and post- * multiplying a real diagonal matrix D with a random orthogonal matrix: * A = U*D*U'. The semi-bandwidth may then be reduced to k by additional * orthogonal transformations. * * Arguments * ========= * * N (input) INTEGER * The order of the matrix A. N >= 0. * * K (input) INTEGER * The number of nonzero subdiagonals within the band of A. * 0 <= K <= N-1. * * D (input) DOUBLE PRECISION array, dimension (N) * The diagonal elements of the diagonal matrix D. * * A (output) DOUBLE PRECISION array, dimension (LDA,N) * The generated n by n symmetric matrix A (the full matrix is * stored). * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= N. * * ISEED (input/output) INTEGER array, dimension (4) * On entry, the seed of the random number generator; the array * elements must be between 0 and 4095, and ISEED(4) must be * odd. * On exit, the seed is updated. * * WORK (workspace) DOUBLE PRECISION array, dimension (2*N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, HALF PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) * .. * .. Local Scalars .. INTEGER I, J DOUBLE PRECISION ALPHA, TAU, WA, WB, WN * .. * .. External Subroutines .. EXTERNAL DAXPY, DGEMV, DGER, DLARNV, DSCAL, DSYMV, $ DSYR2, XERBLA * .. * .. External Functions .. DOUBLE PRECISION DDOT, DNRM2 EXTERNAL DDOT, DNRM2 * .. * .. Intrinsic Functions .. INTRINSIC MAX, SIGN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 ELSE IF( K.LT.0 .OR. K.GT.N-1 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 END IF IF( INFO.LT.0 ) THEN CALL XERBLA( 'DLAGSY', -INFO ) RETURN END IF * * initialize lower triangle of A to diagonal matrix * DO 20 J = 1, N DO 10 I = J + 1, N A( I, J ) = ZERO 10 CONTINUE 20 CONTINUE DO 30 I = 1, N A( I, I ) = D( I ) 30 CONTINUE * * Generate lower triangle of symmetric matrix * DO 40 I = N - 1, 1, -1 * * generate random reflection * CALL DLARNV( 3, ISEED, N-I+1, WORK ) WN = DNRM2( N-I+1, WORK, 1 ) WA = SIGN( WN, WORK( 1 ) ) IF( WN.EQ.ZERO ) THEN TAU = ZERO ELSE WB = WORK( 1 ) + WA CALL DSCAL( N-I, ONE / WB, WORK( 2 ), 1 ) WORK( 1 ) = ONE TAU = WB / WA END IF * * apply random reflection to A(i:n,i:n) from the left * and the right * * compute y := tau * A * u * CALL DSYMV( 'Lower', N-I+1, TAU, A( I, I ), LDA, WORK, 1, ZERO, $ WORK( N+1 ), 1 ) * * compute v := y - 1/2 * tau * ( y, u ) * u * ALPHA = -HALF*TAU*DDOT( N-I+1, WORK( N+1 ), 1, WORK, 1 ) CALL DAXPY( N-I+1, ALPHA, WORK, 1, WORK( N+1 ), 1 ) * * apply the transformation as a rank-2 update to A(i:n,i:n) * CALL DSYR2( 'Lower', N-I+1, -ONE, WORK, 1, WORK( N+1 ), 1, $ A( I, I ), LDA ) 40 CONTINUE * * Reduce number of subdiagonals to K * DO 60 I = 1, N - 1 - K * * generate reflection to annihilate A(k+i+1:n,i) * WN = DNRM2( N-K-I+1, A( K+I, I ), 1 ) WA = SIGN( WN, A( K+I, I ) ) IF( WN.EQ.ZERO ) THEN TAU = ZERO ELSE WB = A( K+I, I ) + WA CALL DSCAL( N-K-I, ONE / WB, A( K+I+1, I ), 1 ) A( K+I, I ) = ONE TAU = WB / WA END IF * * apply reflection to A(k+i:n,i+1:k+i-1) from the left * CALL DGEMV( 'Transpose', N-K-I+1, K-1, ONE, A( K+I, I+1 ), LDA, $ A( K+I, I ), 1, ZERO, WORK, 1 ) CALL DGER( N-K-I+1, K-1, -TAU, A( K+I, I ), 1, WORK, 1, $ A( K+I, I+1 ), LDA ) * * apply reflection to A(k+i:n,k+i:n) from the left and the right * * compute y := tau * A * u * CALL DSYMV( 'Lower', N-K-I+1, TAU, A( K+I, K+I ), LDA, $ A( K+I, I ), 1, ZERO, WORK, 1 ) * * compute v := y - 1/2 * tau * ( y, u ) * u * ALPHA = -HALF*TAU*DDOT( N-K-I+1, WORK, 1, A( K+I, I ), 1 ) CALL DAXPY( N-K-I+1, ALPHA, A( K+I, I ), 1, WORK, 1 ) * * apply symmetric rank-2 update to A(k+i:n,k+i:n) * CALL DSYR2( 'Lower', N-K-I+1, -ONE, A( K+I, I ), 1, WORK, 1, $ A( K+I, K+I ), LDA ) * A( K+I, I ) = -WA DO 50 J = K + I + 1, N A( J, I ) = ZERO 50 CONTINUE 60 CONTINUE * * Store full symmetric matrix * DO 80 J = 1, N DO 70 I = J + 1, N A( J, I ) = A( I, J ) 70 CONTINUE 80 CONTINUE RETURN * * End of DLAGSY * END SHAR_EOF fi # end of overwriting check if test -f 'dlaran.f' then echo shar: will not over-write existing file "'dlaran.f'" else cat << SHAR_EOF > 'dlaran.f' DOUBLE PRECISION FUNCTION DLARAN( ISEED ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Array Arguments .. INTEGER ISEED( 4 ) * .. * * Purpose * ======= * * DLARAN returns a random real number from a uniform (0,1) * distribution. * * Arguments * ========= * * ISEED (input/output) INTEGER array, dimension (4) * On entry, the seed of the random number generator; the array * elements must be between 0 and 4095, and ISEED(4) must be * odd. * On exit, the seed is updated. * * Further Details * =============== * * This routine uses a multiplicative congruential method with modulus * 2**48 and multiplier 33952834046453 (see G.S.Fishman, * 'Multiplicative congruential random number generators with modulus * 2**b: an exhaustive analysis for b = 32 and a partial analysis for * b = 48', Math. Comp. 189, pp 331-344, 1990). * * 48-bit integers are stored in 4 integer array elements with 12 bits * per element. Hence the routine is portable across machines with * integers of 32 bits or more. * * ===================================================================== * * .. Parameters .. INTEGER M1, M2, M3, M4 PARAMETER ( M1 = 494, M2 = 322, M3 = 2508, M4 = 2549 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) INTEGER IPW2 DOUBLE PRECISION R PARAMETER ( IPW2 = 4096, R = ONE / IPW2 ) * .. * .. Local Scalars .. INTEGER IT1, IT2, IT3, IT4 * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MOD * .. * .. Executable Statements .. * * multiply the seed by the multiplier modulo 2**48 * IT4 = ISEED( 4 )*M4 IT3 = IT4 / IPW2 IT4 = IT4 - IPW2*IT3 IT3 = IT3 + ISEED( 3 )*M4 + ISEED( 4 )*M3 IT2 = IT3 / IPW2 IT3 = IT3 - IPW2*IT2 IT2 = IT2 + ISEED( 2 )*M4 + ISEED( 3 )*M3 + ISEED( 4 )*M2 IT1 = IT2 / IPW2 IT2 = IT2 - IPW2*IT1 IT1 = IT1 + ISEED( 1 )*M4 + ISEED( 2 )*M3 + ISEED( 3 )*M2 + $ ISEED( 4 )*M1 IT1 = MOD( IT1, IPW2 ) * * return updated seed * ISEED( 1 ) = IT1 ISEED( 2 ) = IT2 ISEED( 3 ) = IT3 ISEED( 4 ) = IT4 * * convert 48-bit integer to a real number in the interval (0,1) * DLARAN = R*( DBLE( IT1 )+R*( DBLE( IT2 )+R*( DBLE( IT3 )+R* $ ( DBLE( IT4 ) ) ) ) ) RETURN * * End of DLARAN * END SHAR_EOF fi # end of overwriting check if test -f 'dlarge.f' then echo shar: will not over-write existing file "'dlarge.f'" else cat << SHAR_EOF > 'dlarge.f' SUBROUTINE DLARGE( N, A, LDA, ISEED, WORK, INFO ) * * -- LAPACK auxiliary test routine (version 2.0) * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. INTEGER INFO, LDA, N * .. * .. Array Arguments .. INTEGER ISEED( 4 ) DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. * * Purpose * ======= * * DLARGE pre- and post-multiplies a real general n by n matrix A * with a random orthogonal matrix: A = U*D*U'. * * Arguments * ========= * * N (input) INTEGER * The order of the matrix A. N >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the original n by n matrix A. * On exit, A is overwritten by U*A*U' for some random * orthogonal matrix U. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= N. * * ISEED (input/output) INTEGER array, dimension (4) * On entry, the seed of the random number generator; the array * elements must be between 0 and 4095, and ISEED(4) must be * odd. * On exit, the seed is updated. * * WORK (workspace) DOUBLE PRECISION array, dimension (2*N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I DOUBLE PRECISION TAU, WA, WB, WN * .. * .. External Subroutines .. EXTERNAL DGEMV, DGER, DLARNV, DSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, SIGN * .. * .. External Functions .. DOUBLE PRECISION DNRM2 EXTERNAL DNRM2 * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -3 END IF IF( INFO.LT.0 ) THEN CALL XERBLA( 'DLARGE', -INFO ) RETURN END IF * * pre- and post-multiply A by random orthogonal matrix * DO 10 I = N, 1, -1 * * generate random reflection * CALL DLARNV( 3, ISEED, N-I+1, WORK ) WN = DNRM2( N-I+1, WORK, 1 ) WA = SIGN( WN, WORK( 1 ) ) IF( WN.EQ.ZERO ) THEN TAU = ZERO ELSE WB = WORK( 1 ) + WA CALL DSCAL( N-I, ONE / WB, WORK( 2 ), 1 ) WORK( 1 ) = ONE TAU = WB / WA END IF * * multiply A(i:n,1:n) by random reflection from the left * CALL DGEMV( 'Transpose', N-I+1, N, ONE, A( I, 1 ), LDA, WORK, $ 1, ZERO, WORK( N+1 ), 1 ) CALL DGER( N-I+1, N, -TAU, WORK, 1, WORK( N+1 ), 1, A( I, 1 ), $ LDA ) * * multiply A(1:n,i:n) by random reflection from the right * CALL DGEMV( 'No transpose', N, N-I+1, ONE, A( 1, I ), LDA, $ WORK, 1, ZERO, WORK( N+1 ), 1 ) CALL DGER( N, N-I+1, -TAU, WORK( N+1 ), 1, WORK, 1, A( 1, I ), $ LDA ) 10 CONTINUE RETURN * * End of DLARGE * END SHAR_EOF fi # end of overwriting check if test -f 'dlarnd.f' then echo shar: will not over-write existing file "'dlarnd.f'" else cat << SHAR_EOF > 'dlarnd.f' DOUBLE PRECISION FUNCTION DLARND( IDIST, ISEED ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. INTEGER IDIST * .. * .. Array Arguments .. INTEGER ISEED( 4 ) * .. * * Purpose * ======= * * DLARND returns a random real number from a uniform or normal * distribution. * * Arguments * ========= * * IDIST (input) INTEGER * Specifies the distribution of the random numbers: * = 1: uniform (0,1) * = 2: uniform (-1,1) * = 3: normal (0,1) * * ISEED (input/output) INTEGER array, dimension (4) * On entry, the seed of the random number generator; the array * elements must be between 0 and 4095, and ISEED(4) must be * odd. * On exit, the seed is updated. * * Further Details * =============== * * This routine calls the auxiliary routine DLARAN to generate a random * real number from a uniform (0,1) distribution. The Box-Muller method * is used to transform numbers from a uniform to a normal distribution. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, TWO PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0 ) DOUBLE PRECISION TWOPI PARAMETER ( TWOPI = 6.2831853071795864769252867663D+0 ) * .. * .. Local Scalars .. DOUBLE PRECISION T1, T2 * .. * .. External Functions .. DOUBLE PRECISION DLARAN EXTERNAL DLARAN * .. * .. Intrinsic Functions .. INTRINSIC COS, LOG, SQRT * .. * .. Executable Statements .. * * Generate a real random number from a uniform (0,1) distribution * T1 = DLARAN( ISEED ) * IF( IDIST.EQ.1 ) THEN * * uniform (0,1) * DLARND = T1 ELSE IF( IDIST.EQ.2 ) THEN * * uniform (-1,1) * DLARND = TWO*T1 - ONE ELSE IF( IDIST.EQ.3 ) THEN * * normal (0,1) * T2 = DLARAN( ISEED ) DLARND = SQRT( -TWO*LOG( T1 ) )*COS( TWOPI*T2 ) END IF RETURN * * End of DLARND * END SHAR_EOF fi # end of overwriting check if test -f 'dlaror.f' then echo shar: will not over-write existing file "'dlaror.f'" else cat << SHAR_EOF > 'dlaror.f' SUBROUTINE DLAROR( SIDE, INIT, M, N, A, LDA, ISEED, X, INFO ) * * -- LAPACK auxiliary test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER INIT, SIDE INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. INTEGER ISEED( 4 ) DOUBLE PRECISION A( LDA, * ), X( * ) * .. * * Purpose * ======= * * DLAROR pre- or post-multiplies an M by N matrix A by a random * orthogonal matrix U, overwriting A. A may optionally be initialized * to the identity matrix before multiplying by U. U is generated using * the method of G.W. Stewart (SIAM J. Numer. Anal. 17, 1980, 403-409). * * Arguments * ========= * * SIDE (input) CHARACTER*1 * Specifies whether A is multiplied on the left or right by U. * = 'L': Multiply A on the left (premultiply) by U * = 'R': Multiply A on the right (postmultiply) by U' * = 'C' or 'T': Multiply A on the left by U and the right * by U' (Here, U' means U-transpose.) * * INIT (input) CHARACTER*1 * Specifies whether or not A should be initialized to the * identity matrix. * = 'I': Initialize A to (a section of) the identity matrix * before applying U. * = 'N': No initialization. Apply U to the input matrix A. * * INIT = 'I' may be used to generate square or rectangular * orthogonal matrices: * * For M = N and SIDE = 'L' or 'R', the rows will be orthogonal * to each other, as will the columns. * * If M < N, SIDE = 'R' produces a dense matrix whose rows are * orthogonal and whose columns are not, while SIDE = 'L' * produces a matrix whose rows are orthogonal, and whose first * M columns are orthogonal, and whose remaining columns are * zero. * * If M > N, SIDE = 'L' produces a dense matrix whose columns * are orthogonal and whose rows are not, while SIDE = 'R' * produces a matrix whose columns are orthogonal, and whose * first M rows are orthogonal, and whose remaining rows are * zero. * * M (input) INTEGER * The number of rows of A. * * N (input) INTEGER * The number of columns of A. * * A (input/output) DOUBLE PRECISION array, dimension (LDA, N) * On entry, the array A. * On exit, overwritten by U A ( if SIDE = 'L' ), * or by A U ( if SIDE = 'R' ), * or by U A U' ( if SIDE = 'C' or 'T'). * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * ISEED (input/output) INTEGER array, dimension (4) * On entry ISEED specifies the seed of the random number * generator. The array elements should be between 0 and 4095; * if not they will be reduced mod 4096. Also, ISEED(4) must * be odd. The random number generator uses a linear * congruential sequence limited to small integers, and so * should produce machine independent random numbers. The * values of ISEED are changed on exit, and can be used in the * next call to DLAROR to continue the same random number * sequence. * * X (workspace) DOUBLE PRECISION array, dimension (3*MAX( M, N )) * Workspace of length * 2*M + N if SIDE = 'L', * 2*N + M if SIDE = 'R', * 3*N if SIDE = 'C' or 'T'. * * INFO (output) INTEGER * An error flag. It is set to: * = 0: normal return * < 0: if INFO = -k, the k-th argument had an illegal value * = 1: if the random numbers generated by DLARND are bad. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, TOOSML PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, $ TOOSML = 1.0D-20 ) * .. * .. Local Scalars .. INTEGER IROW, ITYPE, IXFRM, J, JCOL, KBEG, NXFRM DOUBLE PRECISION FACTOR, XNORM, XNORMS * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLARND, DNRM2 EXTERNAL LSAME, DLARND, DNRM2 * .. * .. External Subroutines .. EXTERNAL DGEMV, DGER, DLASET, DSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, SIGN * .. * .. Executable Statements .. * IF( N.EQ.0 .OR. M.EQ.0 ) $ RETURN * ITYPE = 0 IF( LSAME( SIDE, 'L' ) ) THEN ITYPE = 1 ELSE IF( LSAME( SIDE, 'R' ) ) THEN ITYPE = 2 ELSE IF( LSAME( SIDE, 'C' ) .OR. LSAME( SIDE, 'T' ) ) THEN ITYPE = 3 END IF * * Check for argument errors. * INFO = 0 IF( ITYPE.EQ.0 ) THEN INFO = -1 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.3 .AND. N.NE.M ) ) THEN INFO = -4 ELSE IF( LDA.LT.M ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLAROR', -INFO ) RETURN END IF * IF( ITYPE.EQ.1 ) THEN NXFRM = M ELSE NXFRM = N END IF * * Initialize A to the identity matrix if desired * IF( LSAME( INIT, 'I' ) ) $ CALL DLASET( 'Full', M, N, ZERO, ONE, A, LDA ) * * If no rotation possible, multiply by random +/-1 * * Compute rotation by computing Householder transformations * H(2), H(3), ..., H(nhouse) * DO 10 J = 1, NXFRM X( J ) = ZERO 10 CONTINUE * DO 30 IXFRM = 2, NXFRM KBEG = NXFRM - IXFRM + 1 * * Generate independent normal( 0, 1 ) random numbers * DO 20 J = KBEG, NXFRM X( J ) = DLARND( 3, ISEED ) 20 CONTINUE * * Generate a Householder transformation from the random vector X * XNORM = DNRM2( IXFRM, X( KBEG ), 1 ) XNORMS = SIGN( XNORM, X( KBEG ) ) X( KBEG+NXFRM ) = SIGN( ONE, -X( KBEG ) ) FACTOR = XNORMS*( XNORMS+X( KBEG ) ) IF( ABS( FACTOR ).LT.TOOSML ) THEN INFO = 1 CALL XERBLA( 'DLAROR', INFO ) RETURN ELSE FACTOR = ONE / FACTOR END IF X( KBEG ) = X( KBEG ) + XNORMS * * Apply Householder transformation to A * IF( ITYPE.EQ.1 .OR. ITYPE.EQ.3 ) THEN * * Apply H(k) from the left. * CALL DGEMV( 'T', IXFRM, N, ONE, A( KBEG, 1 ), LDA, $ X( KBEG ), 1, ZERO, X( 2*NXFRM+1 ), 1 ) CALL DGER( IXFRM, N, -FACTOR, X( KBEG ), 1, X( 2*NXFRM+1 ), $ 1, A( KBEG, 1 ), LDA ) * END IF * IF( ITYPE.EQ.2 .OR. ITYPE.EQ.3 ) THEN * * Apply H(k) from the right. * CALL DGEMV( 'N', M, IXFRM, ONE, A( 1, KBEG ), LDA, $ X( KBEG ), 1, ZERO, X( 2*NXFRM+1 ), 1 ) CALL DGER( M, IXFRM, -FACTOR, X( 2*NXFRM+1 ), 1, X( KBEG ), $ 1, A( 1, KBEG ), LDA ) * END IF 30 CONTINUE * X( 2*NXFRM ) = SIGN( ONE, DLARND( 3, ISEED ) ) * * Scale the matrix A by D. * IF( ITYPE.EQ.1 .OR. ITYPE.EQ.3 ) THEN DO 40 IROW = 1, M CALL DSCAL( N, X( NXFRM+IROW ), A( IROW, 1 ), LDA ) 40 CONTINUE END IF * IF( ITYPE.EQ.2 .OR. ITYPE.EQ.3 ) THEN DO 50 JCOL = 1, N CALL DSCAL( M, X( NXFRM+JCOL ), A( 1, JCOL ), 1 ) 50 CONTINUE END IF RETURN * * End of DLAROR * END SHAR_EOF fi # end of overwriting check if test -f 'dlarot.f' then echo shar: will not over-write existing file "'dlarot.f'" else cat << SHAR_EOF > 'dlarot.f' SUBROUTINE DLAROT( LROWS, LLEFT, LRIGHT, NL, C, S, A, LDA, XLEFT, $ XRIGHT ) * * -- LAPACK auxiliary test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. LOGICAL LLEFT, LRIGHT, LROWS INTEGER LDA, NL DOUBLE PRECISION C, S, XLEFT, XRIGHT * .. * .. Array Arguments .. DOUBLE PRECISION A( * ) * .. * * Purpose * ======= * * DLAROT applies a (Givens) rotation to two adjacent rows or * columns, where one element of the first and/or last column/row * may be a separate variable. This is specifically indended * for use on matrices stored in some format other than GE, so * that elements of the matrix may be used or modified for which * no array element is provided. * * One example is a symmetric matrix in SB format (bandwidth=4), for * which UPLO='L': Two adjacent rows will have the format: * * row j: * * * * * . . . . * row j+1: * * * * * . . . . * * '*' indicates elements for which storage is provided, * '.' indicates elements for which no storage is provided, but * are not necessarily zero; their values are determined by * symmetry. ' ' indicates elements which are necessarily zero, * and have no storage provided. * * Those columns which have two '*'s can be handled by DROT. * Those columns which have no '*'s can be ignored, since as long * as the Givens rotations are carefully applied to preserve * symmetry, their values are determined. * Those columns which have one '*' have to be handled separately, * by using separate variables "p" and "q": * * row j: * * * * * p . . . * row j+1: q * * * * * . . . . * * The element p would have to be set correctly, then that column * is rotated, setting p to its new value. The next call to * DLAROT would rotate columns j and j+1, using p, and restore * symmetry. The element q would start out being zero, and be * made non-zero by the rotation. Later, rotations would presumably * be chosen to zero q out. * * Typical Calling Sequences: rotating the i-th and (i+1)-st rows. * ------- ------- --------- * * General dense matrix: * * CALL DLAROT(.TRUE.,.FALSE.,.FALSE., N, C,S, * A(i,1),LDA, DUMMY, DUMMY) * * General banded matrix in GB format: * * j = MAX(1, i-KL ) * NL = MIN( N, i+KU+1 ) + 1-j * CALL DLAROT( .TRUE., i-KL.GE.1, i+KU.LT.N, NL, C,S, * A(KU+i+1-j,j),LDA-1, XLEFT, XRIGHT ) * * [ note that i+1-j is just MIN(i,KL+1) ] * * Symmetric banded matrix in SY format, bandwidth K, * lower triangle only: * * j = MAX(1, i-K ) * NL = MIN( K+1, i ) + 1 * CALL DLAROT( .TRUE., i-K.GE.1, .TRUE., NL, C,S, * A(i,j), LDA, XLEFT, XRIGHT ) * * Same, but upper triangle only: * * NL = MIN( K+1, N-i ) + 1 * CALL DLAROT( .TRUE., .TRUE., i+K.LT.N, NL, C,S, * A(i,i), LDA, XLEFT, XRIGHT ) * * Symmetric banded matrix in SB format, bandwidth K, * lower triangle only: * * [ same as for SY, except:] * . . . . * A(i+1-j,j), LDA-1, XLEFT, XRIGHT ) * * [ note that i+1-j is just MIN(i,K+1) ] * * Same, but upper triangle only: * . . . * A(K+1,i), LDA-1, XLEFT, XRIGHT ) * * Rotating columns is just the transpose of rotating rows, except * for GB and SB: (rotating columns i and i+1) * * GB: * j = MAX(1, i-KU ) * NL = MIN( N, i+KL+1 ) + 1-j * CALL DLAROT( .TRUE., i-KU.GE.1, i+KL.LT.N, NL, C,S, * A(KU+j+1-i,i),LDA-1, XTOP, XBOTTM ) * * [note that KU+j+1-i is just MAX(1,KU+2-i)] * * SB: (upper triangle) * * . . . . . . * A(K+j+1-i,i),LDA-1, XTOP, XBOTTM ) * * SB: (lower triangle) * * . . . . . . * A(1,i),LDA-1, XTOP, XBOTTM ) * * Arguments * ========= * * LROWS - LOGICAL * If .TRUE., then DLAROT will rotate two rows. If .FALSE., * then it will rotate two columns. * Not modified. * * LLEFT - LOGICAL * If .TRUE., then XLEFT will be used instead of the * corresponding element of A for the first element in the * second row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) * If .FALSE., then the corresponding element of A will be * used. * Not modified. * * LRIGHT - LOGICAL * If .TRUE., then XRIGHT will be used instead of the * corresponding element of A for the last element in the * first row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) If * .FALSE., then the corresponding element of A will be used. * Not modified. * * NL - INTEGER * The length of the rows (if LROWS=.TRUE.) or columns (if * LROWS=.FALSE.) to be rotated. If XLEFT and/or XRIGHT are * used, the columns/rows they are in should be included in * NL, e.g., if LLEFT = LRIGHT = .TRUE., then NL must be at * least 2. The number of rows/columns to be rotated * exclusive of those involving XLEFT and/or XRIGHT may * not be negative, i.e., NL minus how many of LLEFT and * LRIGHT are .TRUE. must be at least zero; if not, XERBLA * will be called. * Not modified. * * C, S - DOUBLE PRECISION * Specify the Givens rotation to be applied. If LROWS is * true, then the matrix ( c s ) * (-s c ) is applied from the left; * if false, then the transpose thereof is applied from the * right. For a Givens rotation, C**2 + S**2 should be 1, * but this is not checked. * Not modified. * * A - DOUBLE PRECISION array. * The array containing the rows/columns to be rotated. The * first element of A should be the upper left element to * be rotated. * Read and modified. * * LDA - INTEGER * The "effective" leading dimension of A. If A contains * a matrix stored in GE or SY format, then this is just * the leading dimension of A as dimensioned in the calling * routine. If A contains a matrix stored in band (GB or SB) * format, then this should be *one less* than the leading * dimension used in the calling routine. Thus, if * A were dimensioned A(LDA,*) in DLAROT, then A(1,j) would * be the j-th element in the first of the two rows * to be rotated, and A(2,j) would be the j-th in the second, * regardless of how the array may be stored in the calling * routine. [A cannot, however, actually be dimensioned thus, * since for band format, the row number may exceed LDA, which * is not legal FORTRAN.] * If LROWS=.TRUE., then LDA must be at least 1, otherwise * it must be at least NL minus the number of .TRUE. values * in XLEFT and XRIGHT. * Not modified. * * XLEFT - DOUBLE PRECISION * If LLEFT is .TRUE., then XLEFT will be used and modified * instead of A(2,1) (if LROWS=.TRUE.) or A(1,2) * (if LROWS=.FALSE.). * Read and modified. * * XRIGHT - DOUBLE PRECISION * If LRIGHT is .TRUE., then XRIGHT will be used and modified * instead of A(1,NL) (if LROWS=.TRUE.) or A(NL,1) * (if LROWS=.FALSE.). * Read and modified. * * ===================================================================== * * .. Local Scalars .. INTEGER IINC, INEXT, IX, IY, IYT, NT * .. * .. Local Arrays .. DOUBLE PRECISION XT( 2 ), YT( 2 ) * .. * .. External Subroutines .. EXTERNAL DROT, XERBLA * .. * .. Executable Statements .. * * Set up indices, arrays for ends * IF( LROWS ) THEN IINC = LDA INEXT = 1 ELSE IINC = 1 INEXT = LDA END IF * IF( LLEFT ) THEN NT = 1 IX = 1 + IINC IY = 2 + LDA XT( 1 ) = A( 1 ) YT( 1 ) = XLEFT ELSE NT = 0 IX = 1 IY = 1 + INEXT END IF * IF( LRIGHT ) THEN IYT = 1 + INEXT + ( NL-1 )*IINC NT = NT + 1 XT( NT ) = XRIGHT YT( NT ) = A( IYT ) END IF * * Check for errors * IF( NL.LT.NT ) THEN CALL XERBLA( 'DLAROT', 4 ) RETURN END IF IF( LDA.LE.0 .OR. ( .NOT.LROWS .AND. LDA.LT.NL-NT ) ) THEN CALL XERBLA( 'DLAROT', 8 ) RETURN END IF * * Rotate * CALL DROT( NL-NT, A( IX ), IINC, A( IY ), IINC, C, S ) CALL DROT( NT, XT, 1, YT, 1, C, S ) * * Stuff values back into XLEFT, XRIGHT, etc. * IF( LLEFT ) THEN A( 1 ) = XT( 1 ) XLEFT = YT( 1 ) END IF * IF( LRIGHT ) THEN XRIGHT = XT( NT ) A( IYT ) = YT( NT ) END IF * RETURN * * End of DLAROT * END SHAR_EOF fi # end of overwriting check if test -f 'dlatm1.f' then echo shar: will not over-write existing file "'dlatm1.f'" else cat << SHAR_EOF > 'dlatm1.f' SUBROUTINE DLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO ) * * -- LAPACK auxiliary test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. INTEGER IDIST, INFO, IRSIGN, MODE, N DOUBLE PRECISION COND * .. * .. Array Arguments .. INTEGER ISEED( 4 ) DOUBLE PRECISION D( * ) * .. * * Purpose * ======= * * DLATM1 computes the entries of D(1..N) as specified by * MODE, COND and IRSIGN. IDIST and ISEED determine the generation * of random numbers. DLATM1 is called by SLATMR to generate * random test matrices for LAPACK programs. * * Arguments * ========= * * MODE - INTEGER * On entry describes how D is to be computed: * MODE = 0 means do not change D. * MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND * MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND * MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) * MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) * MODE = 5 sets D to random numbers in the range * ( 1/COND , 1 ) such that their logarithms * are uniformly distributed. * MODE = 6 set D to random numbers from same distribution * as the rest of the matrix. * MODE < 0 has the same meaning as ABS(MODE), except that * the order of the elements of D is reversed. * Thus if MODE is positive, D has entries ranging from * 1 to 1/COND, if negative, from 1/COND to 1, * Not modified. * * COND - DOUBLE PRECISION * On entry, used as described under MODE above. * If used, it must be >= 1. Not modified. * * IRSIGN - INTEGER * On entry, if MODE neither -6, 0 nor 6, determines sign of * entries of D * 0 => leave entries of D unchanged * 1 => multiply each entry of D by 1 or -1 with probability .5 * * IDIST - CHARACTER*1 * On entry, IDIST specifies the type of distribution to be * used to generate a random matrix . * 1 => UNIFORM( 0, 1 ) * 2 => UNIFORM( -1, 1 ) * 3 => NORMAL( 0, 1 ) * Not modified. * * ISEED - INTEGER array, dimension ( 4 ) * On entry ISEED specifies the seed of the random number * generator. The random number generator uses a * linear congruential sequence limited to small * integers, and so should produce machine independent * random numbers. The values of ISEED are changed on * exit, and can be used in the next call to DLATM1 * to continue the same random number sequence. * Changed on exit. * * D - DOUBLE PRECISION array, dimension ( MIN( M , N ) ) * Array to be computed according to MODE, COND and IRSIGN. * May be changed on exit if MODE is nonzero. * * N - INTEGER * Number of entries of D. Not modified. * * INFO - INTEGER * 0 => normal termination * -1 => if MODE not in range -6 to 6 * -2 => if MODE neither -6, 0 nor 6, and * IRSIGN neither 0 nor 1 * -3 => if MODE neither -6, 0 nor 6 and COND less than 1 * -4 => if MODE equals 6 or -6 and IDIST not in range 1 to 3 * -7 => if N negative * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) DOUBLE PRECISION HALF PARAMETER ( HALF = 0.5D0 ) * .. * .. Local Scalars .. INTEGER I DOUBLE PRECISION ALPHA, TEMP * .. * .. External Functions .. DOUBLE PRECISION DLARAN EXTERNAL DLARAN * .. * .. External Subroutines .. EXTERNAL DLARNV, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, EXP, LOG * .. * .. Executable Statements .. * * Decode and Test the input parameters. Initialize flags & seed. * INFO = 0 * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Set INFO if an error * IF( MODE.LT.-6 .OR. MODE.GT.6 ) THEN INFO = -1 ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND. $ ( IRSIGN.NE.0 .AND. IRSIGN.NE.1 ) ) THEN INFO = -2 ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND. $ COND.LT.ONE ) THEN INFO = -3 ELSE IF( ( MODE.EQ.6 .OR. MODE.EQ.-6 ) .AND. $ ( IDIST.LT.1 .OR. IDIST.GT.3 ) ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -7 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLATM1', -INFO ) RETURN END IF * * Compute D according to COND and MODE * IF( MODE.NE.0 ) THEN GO TO ( 10, 30, 50, 70, 90, 110 )ABS( MODE ) * * One large D value: * 10 CONTINUE DO 20 I = 1, N D( I ) = ONE / COND 20 CONTINUE D( 1 ) = ONE GO TO 120 * * One small D value: * 30 CONTINUE DO 40 I = 1, N D( I ) = ONE 40 CONTINUE D( N ) = ONE / COND GO TO 120 * * Exponentially distributed D values: * 50 CONTINUE D( 1 ) = ONE IF( N.GT.1 ) THEN ALPHA = COND**( -ONE / DBLE( N-1 ) ) DO 60 I = 2, N D( I ) = ALPHA**( I-1 ) 60 CONTINUE END IF GO TO 120 * * Arithmetically distributed D values: * 70 CONTINUE D( 1 ) = ONE IF( N.GT.1 ) THEN TEMP = ONE / COND ALPHA = ( ONE-TEMP ) / DBLE( N-1 ) DO 80 I = 2, N D( I ) = DBLE( N-I )*ALPHA + TEMP 80 CONTINUE END IF GO TO 120 * * Randomly distributed D values on ( 1/COND , 1): * 90 CONTINUE ALPHA = LOG( ONE / COND ) DO 100 I = 1, N D( I ) = EXP( ALPHA*DLARAN( ISEED ) ) 100 CONTINUE GO TO 120 * * Randomly distributed D values from IDIST * 110 CONTINUE CALL DLARNV( IDIST, ISEED, N, D ) * 120 CONTINUE * * If MODE neither -6 nor 0 nor 6, and IRSIGN = 1, assign * random signs to D * IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND. $ IRSIGN.EQ.1 ) THEN DO 130 I = 1, N TEMP = DLARAN( ISEED ) IF( TEMP.GT.HALF ) $ D( I ) = -D( I ) 130 CONTINUE END IF * * Reverse if MODE < 0 * IF( MODE.LT.0 ) THEN DO 140 I = 1, N / 2 TEMP = D( I ) D( I ) = D( N+1-I ) D( N+1-I ) = TEMP 140 CONTINUE END IF * END IF * RETURN * * End of DLATM1 * END SHAR_EOF fi # end of overwriting check if test -f 'dlatm2.f' then echo shar: will not over-write existing file "'dlatm2.f'" else cat << SHAR_EOF > 'dlatm2.f' DOUBLE PRECISION FUNCTION DLATM2( M, N, I, J, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE ) * * -- LAPACK auxiliary test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. * INTEGER I, IDIST, IGRADE, IPVTNG, J, KL, KU, M, N DOUBLE PRECISION SPARSE * .. * * .. Array Arguments .. * INTEGER ISEED( 4 ), IWORK( * ) DOUBLE PRECISION D( * ), DL( * ), DR( * ) * .. * * Purpose * ======= * * DLATM2 returns the (I,J) entry of a random matrix of dimension * (M, N) described by the other paramters. It is called by the * DLATMR routine in order to build random test matrices. No error * checking on parameters is done, because this routine is called in * a tight loop by DLATMR which has already checked the parameters. * * Use of DLATM2 differs from SLATM3 in the order in which the random * number generator is called to fill in random matrix entries. * With DLATM2, the generator is called to fill in the pivoted matrix * columnwise. With DLATM3, the generator is called to fill in the * matrix columnwise, after which it is pivoted. Thus, DLATM3 can * be used to construct random matrices which differ only in their * order of rows and/or columns. DLATM2 is used to construct band * matrices while avoiding calling the random number generator for * entries outside the band (and therefore generating random numbers * * The matrix whose (I,J) entry is returned is constructed as * follows (this routine only computes one entry): * * If I is outside (1..M) or J is outside (1..N), return zero * (this is convenient for generating matrices in band format). * * Generate a matrix A with random entries of distribution IDIST. * * Set the diagonal to D. * * Grade the matrix, if desired, from the left (by DL) and/or * from the right (by DR or DL) as specified by IGRADE. * * Permute, if desired, the rows and/or columns as specified by * IPVTNG and IWORK. * * Band the matrix to have lower bandwidth KL and upper * bandwidth KU. * * Set random entries to zero as specified by SPARSE. * * Arguments * ========= * * M - INTEGER * Number of rows of matrix. Not modified. * * N - INTEGER * Number of columns of matrix. Not modified. * * I - INTEGER * Row of entry to be returned. Not modified. * * J - INTEGER * Column of entry to be returned. Not modified. * * KL - INTEGER * Lower bandwidth. Not modified. * * KU - INTEGER * Upper bandwidth. Not modified. * * IDIST - INTEGER * On entry, IDIST specifies the type of distribution to be * used to generate a random matrix . * 1 => UNIFORM( 0, 1 ) * 2 => UNIFORM( -1, 1 ) * 3 => NORMAL( 0, 1 ) * Not modified. * * ISEED - INTEGER array of dimension ( 4 ) * Seed for random number generator. * Changed on exit. * * D - DOUBLE PRECISION array of dimension ( MIN( I , J ) ) * Diagonal entries of matrix. Not modified. * * IGRADE - INTEGER * Specifies grading of matrix as follows: * 0 => no grading * 1 => matrix premultiplied by diag( DL ) * 2 => matrix postmultiplied by diag( DR ) * 3 => matrix premultiplied by diag( DL ) and * postmultiplied by diag( DR ) * 4 => matrix premultiplied by diag( DL ) and * postmultiplied by inv( diag( DL ) ) * 5 => matrix premultiplied by diag( DL ) and * postmultiplied by diag( DL ) * Not modified. * * DL - DOUBLE PRECISION array ( I or J, as appropriate ) * Left scale factors for grading matrix. Not modified. * * DR - DOUBLE PRECISION array ( I or J, as appropriate ) * Right scale factors for grading matrix. Not modified. * * IPVTNG - INTEGER * On entry specifies pivoting permutations as follows: * 0 => none. * 1 => row pivoting. * 2 => column pivoting. * 3 => full pivoting, i.e., on both sides. * Not modified. * * IWORK - INTEGER array ( I or J, as appropriate ) * This array specifies the permutation used. The * row (or column) in position K was originally in * position IWORK( K ). * This differs from IWORK for DLATM3. Not modified. * * SPARSE - DOUBLE PRECISION between 0. and 1. * On entry specifies the sparsity of the matrix * if sparse matix is to be generated. * SPARSE should lie between 0 and 1. * A uniform ( 0, 1 ) random number x is generated and * compared to SPARSE; if x is larger the matrix entry * is unchanged and if x is smaller the entry is set * to zero. Thus on the average a fraction SPARSE of the * entries will be set to zero. * Not modified. * * ===================================================================== * * .. Parameters .. * DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) * .. * * .. Local Scalars .. * INTEGER ISUB, JSUB DOUBLE PRECISION TEMP * .. * * .. External Functions .. * DOUBLE PRECISION DLARAN, DLARND EXTERNAL DLARAN, DLARND * .. * *----------------------------------------------------------------------- * * .. Executable Statements .. * * * Check for I and J in range * IF( I.LT.1 .OR. I.GT.M .OR. J.LT.1 .OR. J.GT.N ) THEN DLATM2 = ZERO RETURN END IF * * Check for banding * IF( J.GT.I+KU .OR. J.LT.I-KL ) THEN DLATM2 = ZERO RETURN END IF * * Check for sparsity * IF( SPARSE.GT.ZERO ) THEN IF( DLARAN( ISEED ).LT.SPARSE ) THEN DLATM2 = ZERO RETURN END IF END IF * * Compute subscripts depending on IPVTNG * IF( IPVTNG.EQ.0 ) THEN ISUB = I JSUB = J ELSE IF( IPVTNG.EQ.1 ) THEN ISUB = IWORK( I ) JSUB = J ELSE IF( IPVTNG.EQ.2 ) THEN ISUB = I JSUB = IWORK( J ) ELSE IF( IPVTNG.EQ.3 ) THEN ISUB = IWORK( I ) JSUB = IWORK( J ) END IF * * Compute entry and grade it according to IGRADE * IF( ISUB.EQ.JSUB ) THEN TEMP = D( ISUB ) ELSE TEMP = DLARND( IDIST, ISEED ) END IF IF( IGRADE.EQ.1 ) THEN TEMP = TEMP*DL( ISUB ) ELSE IF( IGRADE.EQ.2 ) THEN TEMP = TEMP*DR( JSUB ) ELSE IF( IGRADE.EQ.3 ) THEN TEMP = TEMP*DL( ISUB )*DR( JSUB ) ELSE IF( IGRADE.EQ.4 .AND. ISUB.NE.JSUB ) THEN TEMP = TEMP*DL( ISUB ) / DL( JSUB ) ELSE IF( IGRADE.EQ.5 ) THEN TEMP = TEMP*DL( ISUB )*DL( JSUB ) END IF DLATM2 = TEMP RETURN * * End of DLATM2 * END SHAR_EOF fi # end of overwriting check if test -f 'dlatm3.f' then echo shar: will not over-write existing file "'dlatm3.f'" else cat << SHAR_EOF > 'dlatm3.f' DOUBLE PRECISION FUNCTION DLATM3( M, N, I, J, ISUB, JSUB, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, $ SPARSE ) * * -- LAPACK auxiliary test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. * INTEGER I, IDIST, IGRADE, IPVTNG, ISUB, J, JSUB, KL, $ KU, M, N DOUBLE PRECISION SPARSE * .. * * .. Array Arguments .. * INTEGER ISEED( 4 ), IWORK( * ) DOUBLE PRECISION D( * ), DL( * ), DR( * ) * .. * * Purpose * ======= * * DLATM3 returns the (ISUB,JSUB) entry of a random matrix of * dimension (M, N) described by the other paramters. (ISUB,JSUB) * is the final position of the (I,J) entry after pivoting * according to IPVTNG and IWORK. DLATM3 is called by the * DLATMR routine in order to build random test matrices. No error * checking on parameters is done, because this routine is called in * a tight loop by DLATMR which has already checked the parameters. * * Use of DLATM3 differs from SLATM2 in the order in which the random * number generator is called to fill in random matrix entries. * With DLATM2, the generator is called to fill in the pivoted matrix * columnwise. With DLATM3, the generator is called to fill in the * matrix columnwise, after which it is pivoted. Thus, DLATM3 can * be used to construct random matrices which differ only in their * order of rows and/or columns. DLATM2 is used to construct band * matrices while avoiding calling the random number generator for * entries outside the band (and therefore generating random numbers * in different orders for different pivot orders). * * The matrix whose (ISUB,JSUB) entry is returned is constructed as * follows (this routine only computes one entry): * * If ISUB is outside (1..M) or JSUB is outside (1..N), return zero * (this is convenient for generating matrices in band format). * * Generate a matrix A with random entries of distribution IDIST. * * Set the diagonal to D. * * Grade the matrix, if desired, from the left (by DL) and/or * from the right (by DR or DL) as specified by IGRADE. * * Permute, if desired, the rows and/or columns as specified by * IPVTNG and IWORK. * * Band the matrix to have lower bandwidth KL and upper * bandwidth KU. * * Set random entries to zero as specified by SPARSE. * * Arguments * ========= * * M - INTEGER * Number of rows of matrix. Not modified. * * N - INTEGER * Number of columns of matrix. Not modified. * * I - INTEGER * Row of unpivoted entry to be returned. Not modified. * * J - INTEGER * Column of unpivoted entry to be returned. Not modified. * * ISUB - INTEGER * Row of pivoted entry to be returned. Changed on exit. * * JSUB - INTEGER * Column of pivoted entry to be returned. Changed on exit. * * KL - INTEGER * Lower bandwidth. Not modified. * * KU - INTEGER * Upper bandwidth. Not modified. * * IDIST - INTEGER * On entry, IDIST specifies the type of distribution to be * used to generate a random matrix . * 1 => UNIFORM( 0, 1 ) * 2 => UNIFORM( -1, 1 ) * 3 => NORMAL( 0, 1 ) * Not modified. * * ISEED - INTEGER array of dimension ( 4 ) * Seed for random number generator. * Changed on exit. * * D - DOUBLE PRECISION array of dimension ( MIN( I , J ) ) * Diagonal entries of matrix. Not modified. * * IGRADE - INTEGER * Specifies grading of matrix as follows: * 0 => no grading * 1 => matrix premultiplied by diag( DL ) * 2 => matrix postmultiplied by diag( DR ) * 3 => matrix premultiplied by diag( DL ) and * postmultiplied by diag( DR ) * 4 => matrix premultiplied by diag( DL ) and * postmultiplied by inv( diag( DL ) ) * 5 => matrix premultiplied by diag( DL ) and * postmultiplied by diag( DL ) * Not modified. * * DL - DOUBLE PRECISION array ( I or J, as appropriate ) * Left scale factors for grading matrix. Not modified. * * DR - DOUBLE PRECISION array ( I or J, as appropriate ) * Right scale factors for grading matrix. Not modified. * * IPVTNG - INTEGER * On entry specifies pivoting permutations as follows: * 0 => none. * 1 => row pivoting. * 2 => column pivoting. * 3 => full pivoting, i.e., on both sides. * Not modified. * * IWORK - INTEGER array ( I or J, as appropriate ) * This array specifies the permutation used. The * row (or column) originally in position K is in * position IWORK( K ) after pivoting. * This differs from IWORK for DLATM2. Not modified. * * SPARSE - DOUBLE PRECISION between 0. and 1. * On entry specifies the sparsity of the matrix * if sparse matix is to be generated. * SPARSE should lie between 0 and 1. * A uniform ( 0, 1 ) random number x is generated and * compared to SPARSE; if x is larger the matrix entry * is unchanged and if x is smaller the entry is set * to zero. Thus on the average a fraction SPARSE of the * entries will be set to zero. * Not modified. * * ===================================================================== * * .. Parameters .. * DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) * .. * * .. Local Scalars .. * DOUBLE PRECISION TEMP * .. * * .. External Functions .. * DOUBLE PRECISION DLARAN, DLARND EXTERNAL DLARAN, DLARND * .. * *----------------------------------------------------------------------- * * .. Executable Statements .. * * * Check for I and J in range * IF( I.LT.1 .OR. I.GT.M .OR. J.LT.1 .OR. J.GT.N ) THEN ISUB = I JSUB = J DLATM3 = ZERO RETURN END IF * * Compute subscripts depending on IPVTNG * IF( IPVTNG.EQ.0 ) THEN ISUB = I JSUB = J ELSE IF( IPVTNG.EQ.1 ) THEN ISUB = IWORK( I ) JSUB = J ELSE IF( IPVTNG.EQ.2 ) THEN ISUB = I JSUB = IWORK( J ) ELSE IF( IPVTNG.EQ.3 ) THEN ISUB = IWORK( I ) JSUB = IWORK( J ) END IF * * Check for banding * IF( JSUB.GT.ISUB+KU .OR. JSUB.LT.ISUB-KL ) THEN DLATM3 = ZERO RETURN END IF * * Check for sparsity * IF( SPARSE.GT.ZERO ) THEN IF( DLARAN( ISEED ).LT.SPARSE ) THEN DLATM3 = ZERO RETURN END IF END IF * * Compute entry and grade it according to IGRADE * IF( I.EQ.J ) THEN TEMP = D( I ) ELSE TEMP = DLARND( IDIST, ISEED ) END IF IF( IGRADE.EQ.1 ) THEN TEMP = TEMP*DL( I ) ELSE IF( IGRADE.EQ.2 ) THEN TEMP = TEMP*DR( J ) ELSE IF( IGRADE.EQ.3 ) THEN TEMP = TEMP*DL( I )*DR( J ) ELSE IF( IGRADE.EQ.4 .AND. I.NE.J ) THEN TEMP = TEMP*DL( I ) / DL( J ) ELSE IF( IGRADE.EQ.5 ) THEN TEMP = TEMP*DL( I )*DL( J ) END IF DLATM3 = TEMP RETURN * * End of DLATM3 * END SHAR_EOF fi # end of overwriting check if test -f 'dlatme.f' then echo shar: will not over-write existing file "'dlatme.f'" else cat << SHAR_EOF > 'dlatme.f' SUBROUTINE DLATME( N, DIST, ISEED, D, MODE, COND, DMAX, EI, RSIGN, $ UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, A, $ LDA, WORK, INFO ) * * -- LAPACK test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER DIST, RSIGN, SIM, UPPER INTEGER INFO, KL, KU, LDA, MODE, MODES, N DOUBLE PRECISION ANORM, COND, CONDS, DMAX * .. * .. Array Arguments .. CHARACTER EI( * ) INTEGER ISEED( 4 ) DOUBLE PRECISION A( LDA, * ), D( * ), DS( * ), WORK( * ) * .. * * Purpose * ======= * * DLATME generates random non-symmetric square matrices with * specified eigenvalues for testing LAPACK programs. * * DLATME operates by applying the following sequence of * operations: * * 1. Set the diagonal to D, where D may be input or * computed according to MODE, COND, DMAX, and RSIGN * as described below. * * 2. If complex conjugate pairs are desired (MODE=0 and EI(1)='R', * or MODE=5), certain pairs of adjacent elements of D are * interpreted as the real and complex parts of a complex * conjugate pair; A thus becomes block diagonal, with 1x1 * and 2x2 blocks. * * 3. If UPPER='T', the upper triangle of A is set to random values * out of distribution DIST. * * 4. If SIM='T', A is multiplied on the left by a random matrix * X, whose singular values are specified by DS, MODES, and * CONDS, and on the right by X inverse. * * 5. If KL < N-1, the lower bandwidth is reduced to KL using * Householder transformations. If KU < N-1, the upper * bandwidth is reduced to KU. * * 6. If ANORM is not negative, the matrix is scaled to have * maximum-element-norm ANORM. * * (Note: since the matrix cannot be reduced beyond Hessenberg form, * no packing options are available.) * * Arguments * ========= * * N - INTEGER * The number of columns (or rows) of A. Not modified. * * DIST - CHARACTER*1 * On entry, DIST specifies the type of distribution to be used * to generate the random eigen-/singular values, and for the * upper triangle (see UPPER). * 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) * 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) * 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) * Not modified. * * ISEED - INTEGER array, dimension ( 4 ) * On entry ISEED specifies the seed of the random number * generator. They should lie between 0 and 4095 inclusive, * and ISEED(4) should be odd. The random number generator * uses a linear congruential sequence limited to small * integers, and so should produce machine independent * random numbers. The values of ISEED are changed on * exit, and can be used in the next call to DLATME * to continue the same random number sequence. * Changed on exit. * * D - DOUBLE PRECISION array, dimension ( N ) * This array is used to specify the eigenvalues of A. If * MODE=0, then D is assumed to contain the eigenvalues (but * see the description of EI), otherwise they will be * computed according to MODE, COND, DMAX, and RSIGN and * placed in D. * Modified if MODE is nonzero. * * MODE - INTEGER * On entry this describes how the eigenvalues are to * be specified: * MODE = 0 means use D (with EI) as input * MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND * MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND * MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) * MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) * MODE = 5 sets D to random numbers in the range * ( 1/COND , 1 ) such that their logarithms * are uniformly distributed. Each odd-even pair * of elements will be either used as two real * eigenvalues or as the real and imaginary part * of a complex conjugate pair of eigenvalues; * the choice of which is done is random, with * 50-50 probability, for each pair. * MODE = 6 set D to random numbers from same distribution * as the rest of the matrix. * MODE < 0 has the same meaning as ABS(MODE), except that * the order of the elements of D is reversed. * Thus if MODE is between 1 and 4, D has entries ranging * from 1 to 1/COND, if between -1 and -4, D has entries * ranging from 1/COND to 1, * Not modified. * * COND - DOUBLE PRECISION * On entry, this is used as described under MODE above. * If used, it must be >= 1. Not modified. * * DMAX - DOUBLE PRECISION * If MODE is neither -6, 0 nor 6, the contents of D, as * computed according to MODE and COND, will be scaled by * DMAX / max(abs(D(i))). Note that DMAX need not be * positive: if DMAX is negative (or zero), D will be * scaled by a negative number (or zero). * Not modified. * * EI - CHARACTER*1 array, dimension ( N ) * If MODE is 0, and EI(1) is not ' ' (space character), * this array specifies which elements of D (on input) are * real eigenvalues and which are the real and imaginary parts * of a complex conjugate pair of eigenvalues. The elements * of EI may then only have the values 'R' and 'I'. If * EI(j)='R' and EI(j+1)='I', then the j-th eigenvalue is * CMPLX( D(j) , D(j+1) ), and the (j+1)-th is the complex * conjugate thereof. If EI(j)=EI(j+1)='R', then the j-th * eigenvalue is D(j) (i.e., real). EI(1) may not be 'I', * nor may two adjacent elements of EI both have the value 'I'. * If MODE is not 0, then EI is ignored. If MODE is 0 and * EI(1)=' ', then the eigenvalues will all be real. * Not modified. * * RSIGN - CHARACTER*1 * If MODE is not 0, 6, or -6, and RSIGN='T', then the * elements of D, as computed according to MODE and COND, will * be multiplied by a random sign (+1 or -1). If RSIGN='F', * they will not be. RSIGN may only have the values 'T' or * 'F'. * Not modified. * * UPPER - CHARACTER*1 * If UPPER='T', then the elements of A above the diagonal * (and above the 2x2 diagonal blocks, if A has complex * eigenvalues) will be set to random numbers out of DIST. * If UPPER='F', they will not. UPPER may only have the * values 'T' or 'F'. * Not modified. * * SIM - CHARACTER*1 * If SIM='T', then A will be operated on by a "similarity * transform", i.e., multiplied on the left by a matrix X and * on the right by X inverse. X = U S V, where U and V are * random unitary matrices and S is a (diagonal) matrix of * singular values specified by DS, MODES, and CONDS. If * SIM='F', then A will not be transformed. * Not modified. * * DS - DOUBLE PRECISION array, dimension ( N ) * This array is used to specify the singular values of X, * in the same way that D specifies the eigenvalues of A. * If MODE=0, the DS contains the singular values, which * may not be zero. * Modified if MODE is nonzero. * * MODES - INTEGER * CONDS - DOUBLE PRECISION * Same as MODE and COND, but for specifying the diagonal * of S. MODES=-6 and +6 are not allowed (since they would * result in randomly ill-conditioned eigenvalues.) * * KL - INTEGER * This specifies the lower bandwidth of the matrix. KL=1 * specifies upper Hessenberg form. If KL is at least N-1, * then A will have full lower bandwidth. KL must be at * least 1. * Not modified. * * KU - INTEGER * This specifies the upper bandwidth of the matrix. KU=1 * specifies lower Hessenberg form. If KU is at least N-1, * then A will have full upper bandwidth; if KU and KL * are both at least N-1, then A will be dense. Only one of * KU and KL may be less than N-1. KU must be at least 1. * Not modified. * * ANORM - DOUBLE PRECISION * If ANORM is not negative, then A will be scaled by a non- * negative real number to make the maximum-element-norm of A * to be ANORM. * Not modified. * * A - DOUBLE PRECISION array, dimension ( LDA, N ) * On exit A is the desired test matrix. * Modified. * * LDA - INTEGER * LDA specifies the first dimension of A as declared in the * calling program. LDA must be at least N. * Not modified. * * WORK - DOUBLE PRECISION array, dimension ( 3*N ) * Workspace. * Modified. * * INFO - INTEGER * Error code. On exit, INFO will be set to one of the * following values: * 0 => normal return * -1 => N negative * -2 => DIST illegal string * -5 => MODE not in range -6 to 6 * -6 => COND less than 1.0, and MODE neither -6, 0 nor 6 * -8 => EI(1) is not ' ' or 'R', EI(j) is not 'R' or 'I', or * two adjacent elements of EI are 'I'. * -9 => RSIGN is not 'T' or 'F' * -10 => UPPER is not 'T' or 'F' * -11 => SIM is not 'T' or 'F' * -12 => MODES=0 and DS has a zero singular value. * -13 => MODES is not in the range -5 to 5. * -14 => MODES is nonzero and CONDS is less than 1. * -15 => KL is less than 1. * -16 => KU is less than 1, or KL and KU are both less than * N-1. * -19 => LDA is less than N. * 1 => Error return from DLATM1 (computing D) * 2 => Cannot scale to DMAX (max. eigenvalue is 0) * 3 => Error return from DLATM1 (computing DS) * 4 => Error return from DLARGE * 5 => Zero singular value from DLATM1. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) DOUBLE PRECISION HALF PARAMETER ( HALF = 1.0D0 / 2.0D0 ) * .. * .. Local Scalars .. LOGICAL BADEI, BADS, USEEI INTEGER I, IC, ICOLS, IDIST, IINFO, IR, IROWS, IRSIGN, $ ISIM, IUPPER, J, JC, JCR, JR DOUBLE PRECISION ALPHA, TAU, TEMP, XNORMS * .. * .. Local Arrays .. DOUBLE PRECISION TEMPA( 1 ) * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLANGE, DLARAN EXTERNAL LSAME, DLANGE, DLARAN * .. * .. External Subroutines .. EXTERNAL DCOPY, DGEMV, DGER, DLARFG, DLARGE, DLARNV, $ DLASET, DLATM1, DSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MOD * .. * .. Executable Statements .. * * 1) Decode and Test the input parameters. * Initialize flags & seed. * INFO = 0 * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Decode DIST * IF( LSAME( DIST, 'U' ) ) THEN IDIST = 1 ELSE IF( LSAME( DIST, 'S' ) ) THEN IDIST = 2 ELSE IF( LSAME( DIST, 'N' ) ) THEN IDIST = 3 ELSE IDIST = -1 END IF * * Check EI * USEEI = .TRUE. BADEI = .FALSE. IF( LSAME( EI( 1 ), ' ' ) .OR. MODE.NE.0 ) THEN USEEI = .FALSE. ELSE IF( LSAME( EI( 1 ), 'R' ) ) THEN DO 10 J = 2, N IF( LSAME( EI( J ), 'I' ) ) THEN IF( LSAME( EI( J-1 ), 'I' ) ) $ BADEI = .TRUE. ELSE IF( .NOT.LSAME( EI( J ), 'R' ) ) $ BADEI = .TRUE. END IF 10 CONTINUE ELSE BADEI = .TRUE. END IF END IF * * Decode RSIGN * IF( LSAME( RSIGN, 'T' ) ) THEN IRSIGN = 1 ELSE IF( LSAME( RSIGN, 'F' ) ) THEN IRSIGN = 0 ELSE IRSIGN = -1 END IF * * Decode UPPER * IF( LSAME( UPPER, 'T' ) ) THEN IUPPER = 1 ELSE IF( LSAME( UPPER, 'F' ) ) THEN IUPPER = 0 ELSE IUPPER = -1 END IF * * Decode SIM * IF( LSAME( SIM, 'T' ) ) THEN ISIM = 1 ELSE IF( LSAME( SIM, 'F' ) ) THEN ISIM = 0 ELSE ISIM = -1 END IF * * Check DS, if MODES=0 and ISIM=1 * BADS = .FALSE. IF( MODES.EQ.0 .AND. ISIM.EQ.1 ) THEN DO 20 J = 1, N IF( DS( J ).EQ.ZERO ) $ BADS = .TRUE. 20 CONTINUE END IF * * Set INFO if an error * IF( N.LT.0 ) THEN INFO = -1 ELSE IF( IDIST.EQ.-1 ) THEN INFO = -2 ELSE IF( ABS( MODE ).GT.6 ) THEN INFO = -5 ELSE IF( ( MODE.NE.0 .AND. ABS( MODE ).NE.6 ) .AND. COND.LT.ONE ) $ THEN INFO = -6 ELSE IF( BADEI ) THEN INFO = -8 ELSE IF( IRSIGN.EQ.-1 ) THEN INFO = -9 ELSE IF( IUPPER.EQ.-1 ) THEN INFO = -10 ELSE IF( ISIM.EQ.-1 ) THEN INFO = -11 ELSE IF( BADS ) THEN INFO = -12 ELSE IF( ISIM.EQ.1 .AND. ABS( MODES ).GT.5 ) THEN INFO = -13 ELSE IF( ISIM.EQ.1 .AND. MODES.NE.0 .AND. CONDS.LT.ONE ) THEN INFO = -14 ELSE IF( KL.LT.1 ) THEN INFO = -15 ELSE IF( KU.LT.1 .OR. ( KU.LT.N-1 .AND. KL.LT.N-1 ) ) THEN INFO = -16 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -19 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLATME', -INFO ) RETURN END IF * * Initialize random number generator * DO 30 I = 1, 4 ISEED( I ) = MOD( ABS( ISEED( I ) ), 4096 ) 30 CONTINUE * IF( MOD( ISEED( 4 ), 2 ).NE.1 ) $ ISEED( 4 ) = ISEED( 4 ) + 1 * * 2) Set up diagonal of A * * Compute D according to COND and MODE * CALL DLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, IINFO ) IF( IINFO.NE.0 ) THEN INFO = 1 RETURN END IF IF( MODE.NE.0 .AND. ABS( MODE ).NE.6 ) THEN * * Scale by DMAX * TEMP = ABS( D( 1 ) ) DO 40 I = 2, N TEMP = MAX( TEMP, ABS( D( I ) ) ) 40 CONTINUE * IF( TEMP.GT.ZERO ) THEN ALPHA = DMAX / TEMP ELSE IF( DMAX.NE.ZERO ) THEN INFO = 2 RETURN ELSE ALPHA = ZERO END IF * CALL DSCAL( N, ALPHA, D, 1 ) * END IF * CALL DLASET( 'Full', N, N, ZERO, ZERO, A, LDA ) CALL DCOPY( N, D, 1, A, LDA+1 ) * * Set up complex conjugate pairs * IF( MODE.EQ.0 ) THEN IF( USEEI ) THEN DO 50 J = 2, N IF( LSAME( EI( J ), 'I' ) ) THEN A( J-1, J ) = A( J, J ) A( J, J-1 ) = -A( J, J ) A( J, J ) = A( J-1, J-1 ) END IF 50 CONTINUE END IF * ELSE IF( ABS( MODE ).EQ.5 ) THEN * DO 60 J = 2, N, 2 IF( DLARAN( ISEED ).GT.HALF ) THEN A( J-1, J ) = A( J, J ) A( J, J-1 ) = -A( J, J ) A( J, J ) = A( J-1, J-1 ) END IF 60 CONTINUE END IF * * 3) If UPPER='T', set upper triangle of A to random numbers. * (but don't modify the corners of 2x2 blocks.) * IF( IUPPER.NE.0 ) THEN DO 70 JC = 2, N IF( A( JC-1, JC ).NE.ZERO ) THEN JR = JC - 2 ELSE JR = JC - 1 END IF CALL DLARNV( IDIST, ISEED, JR, A( 1, JC ) ) 70 CONTINUE END IF * * 4) If SIM='T', apply similarity transformation. * * -1 * Transform is X A X , where X = U S V, thus * * it is U S V A V' (1/S) U' * IF( ISIM.NE.0 ) THEN * * Compute S (singular values of the eigenvector matrix) * according to CONDS and MODES * CALL DLATM1( MODES, CONDS, 0, 0, ISEED, DS, N, IINFO ) IF( IINFO.NE.0 ) THEN INFO = 3 RETURN END IF * * Multiply by V and V' * CALL DLARGE( N, A, LDA, ISEED, WORK, IINFO ) IF( IINFO.NE.0 ) THEN INFO = 4 RETURN END IF * * Multiply by S and (1/S) * DO 80 J = 1, N CALL DSCAL( N, DS( J ), A( J, 1 ), LDA ) IF( DS( J ).NE.ZERO ) THEN CALL DSCAL( N, ONE / DS( J ), A( 1, J ), 1 ) ELSE INFO = 5 RETURN END IF 80 CONTINUE * * Multiply by U and U' * CALL DLARGE( N, A, LDA, ISEED, WORK, IINFO ) IF( IINFO.NE.0 ) THEN INFO = 4 RETURN END IF END IF * * 5) Reduce the bandwidth. * IF( KL.LT.N-1 ) THEN * * Reduce bandwidth -- kill column * DO 90 JCR = KL + 1, N - 1 IC = JCR - KL IROWS = N + 1 - JCR ICOLS = N + KL - JCR * CALL DCOPY( IROWS, A( JCR, IC ), 1, WORK, 1 ) XNORMS = WORK( 1 ) CALL DLARFG( IROWS, XNORMS, WORK( 2 ), 1, TAU ) WORK( 1 ) = ONE * CALL DGEMV( 'T', IROWS, ICOLS, ONE, A( JCR, IC+1 ), LDA, $ WORK, 1, ZERO, WORK( IROWS+1 ), 1 ) CALL DGER( IROWS, ICOLS, -TAU, WORK, 1, WORK( IROWS+1 ), 1, $ A( JCR, IC+1 ), LDA ) * CALL DGEMV( 'N', N, IROWS, ONE, A( 1, JCR ), LDA, WORK, 1, $ ZERO, WORK( IROWS+1 ), 1 ) CALL DGER( N, IROWS, -TAU, WORK( IROWS+1 ), 1, WORK, 1, $ A( 1, JCR ), LDA ) * A( JCR, IC ) = XNORMS CALL DLASET( 'Full', IROWS-1, 1, ZERO, ZERO, A( JCR+1, IC ), $ LDA ) 90 CONTINUE ELSE IF( KU.LT.N-1 ) THEN * * Reduce upper bandwidth -- kill a row at a time. * DO 100 JCR = KU + 1, N - 1 IR = JCR - KU IROWS = N + KU - JCR ICOLS = N + 1 - JCR * CALL DCOPY( ICOLS, A( IR, JCR ), LDA, WORK, 1 ) XNORMS = WORK( 1 ) CALL DLARFG( ICOLS, XNORMS, WORK( 2 ), 1, TAU ) WORK( 1 ) = ONE * CALL DGEMV( 'N', IROWS, ICOLS, ONE, A( IR+1, JCR ), LDA, $ WORK, 1, ZERO, WORK( ICOLS+1 ), 1 ) CALL DGER( IROWS, ICOLS, -TAU, WORK( ICOLS+1 ), 1, WORK, 1, $ A( IR+1, JCR ), LDA ) * CALL DGEMV( 'C', ICOLS, N, ONE, A( JCR, 1 ), LDA, WORK, 1, $ ZERO, WORK( ICOLS+1 ), 1 ) CALL DGER( ICOLS, N, -TAU, WORK, 1, WORK( ICOLS+1 ), 1, $ A( JCR, 1 ), LDA ) * A( IR, JCR ) = XNORMS CALL DLASET( 'Full', 1, ICOLS-1, ZERO, ZERO, A( IR, JCR+1 ), $ LDA ) 100 CONTINUE END IF * * Scale the matrix to have norm ANORM * IF( ANORM.GE.ZERO ) THEN TEMP = DLANGE( 'M', N, N, A, LDA, TEMPA ) IF( TEMP.GT.ZERO ) THEN ALPHA = ANORM / TEMP DO 110 J = 1, N CALL DSCAL( N, ALPHA, A( 1, J ), 1 ) 110 CONTINUE END IF END IF * RETURN * * End of DLATME * END SHAR_EOF fi # end of overwriting check if test -f 'dlatmr.f' then echo shar: will not over-write existing file "'dlatmr.f'" else cat << SHAR_EOF > 'dlatmr.f' SUBROUTINE DLATMR( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, $ RSIGN, GRADE, DL, MODEL, CONDL, DR, MODER, $ CONDR, PIVTNG, IPIVOT, KL, KU, SPARSE, ANORM, $ PACK, A, LDA, IWORK, INFO ) * * -- LAPACK test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER DIST, GRADE, PACK, PIVTNG, RSIGN, SYM INTEGER INFO, KL, KU, LDA, M, MODE, MODEL, MODER, N DOUBLE PRECISION ANORM, COND, CONDL, CONDR, DMAX, SPARSE * .. * .. Array Arguments .. INTEGER IPIVOT( * ), ISEED( 4 ), IWORK( * ) DOUBLE PRECISION A( LDA, * ), D( * ), DL( * ), DR( * ) * .. * * Purpose * ======= * * DLATMR generates random matrices of various types for testing * LAPACK programs. * * DLATMR operates by applying the following sequence of * operations: * * Generate a matrix A with random entries of distribution DIST * which is symmetric if SYM='S', and nonsymmetric * if SYM='N'. * * Set the diagonal to D, where D may be input or * computed according to MODE, COND, DMAX and RSIGN * as described below. * * Grade the matrix, if desired, from the left and/or right * as specified by GRADE. The inputs DL, MODEL, CONDL, DR, * MODER and CONDR also determine the grading as described * below. * * Permute, if desired, the rows and/or columns as specified by * PIVTNG and IPIVOT. * * Set random entries to zero, if desired, to get a random sparse * matrix as specified by SPARSE. * * Make A a band matrix, if desired, by zeroing out the matrix * outside a band of lower bandwidth KL and upper bandwidth KU. * * Scale A, if desired, to have maximum entry ANORM. * * Pack the matrix if desired. Options specified by PACK are: * no packing * zero out upper half (if symmetric) * zero out lower half (if symmetric) * store the upper half columnwise (if symmetric or * square upper triangular) * store the lower half columnwise (if symmetric or * square lower triangular) * same as upper half rowwise if symmetric * store the lower triangle in banded format (if symmetric) * store the upper triangle in banded format (if symmetric) * store the entire matrix in banded format * * Note: If two calls to DLATMR differ only in the PACK parameter, * they will generate mathematically equivalent matrices. * * If two calls to DLATMR both have full bandwidth (KL = M-1 * and KU = N-1), and differ only in the PIVTNG and PACK * parameters, then the matrices generated will differ only * in the order of the rows and/or columns, and otherwise * contain the same data. This consistency cannot be and * is not maintained with less than full bandwidth. * * Arguments * ========= * * M - INTEGER * Number of rows of A. Not modified. * * N - INTEGER * Number of columns of A. Not modified. * * DIST - CHARACTER*1 * On entry, DIST specifies the type of distribution to be used * to generate a random matrix . * 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) * 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) * 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) * Not modified. * * ISEED - INTEGER array, dimension (4) * On entry ISEED specifies the seed of the random number * generator. They should lie between 0 and 4095 inclusive, * and ISEED(4) should be odd. The random number generator * uses a linear congruential sequence limited to small * integers, and so should produce machine independent * random numbers. The values of ISEED are changed on * exit, and can be used in the next call to DLATMR * to continue the same random number sequence. * Changed on exit. * * SYM - CHARACTER*1 * If SYM='S' or 'H', generated matrix is symmetric. * If SYM='N', generated matrix is nonsymmetric. * Not modified. * * D - DOUBLE PRECISION array, dimension (min(M,N)) * On entry this array specifies the diagonal entries * of the diagonal of A. D may either be specified * on entry, or set according to MODE and COND as described * below. May be changed on exit if MODE is nonzero. * * MODE - INTEGER * On entry describes how D is to be used: * MODE = 0 means use D as input * MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND * MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND * MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) * MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) * MODE = 5 sets D to random numbers in the range * ( 1/COND , 1 ) such that their logarithms * are uniformly distributed. * MODE = 6 set D to random numbers from same distribution * as the rest of the matrix. * MODE < 0 has the same meaning as ABS(MODE), except that * the order of the elements of D is reversed. * Thus if MODE is positive, D has entries ranging from * 1 to 1/COND, if negative, from 1/COND to 1, * Not modified. * * COND - DOUBLE PRECISION * On entry, used as described under MODE above. * If used, it must be >= 1. Not modified. * * DMAX - DOUBLE PRECISION * If MODE neither -6, 0 nor 6, the diagonal is scaled by * DMAX / max(abs(D(i))), so that maximum absolute entry * of diagonal is abs(DMAX). If DMAX is negative (or zero), * diagonal will be scaled by a negative number (or zero). * * RSIGN - CHARACTER*1 * If MODE neither -6, 0 nor 6, specifies sign of diagonal * as follows: * 'T' => diagonal entries are multiplied by 1 or -1 * with probability .5 * 'F' => diagonal unchanged * Not modified. * * GRADE - CHARACTER*1 * Specifies grading of matrix as follows: * 'N' => no grading * 'L' => matrix premultiplied by diag( DL ) * (only if matrix nonsymmetric) * 'R' => matrix postmultiplied by diag( DR ) * (only if matrix nonsymmetric) * 'B' => matrix premultiplied by diag( DL ) and * postmultiplied by diag( DR ) * (only if matrix nonsymmetric) * 'S' or 'H' => matrix premultiplied by diag( DL ) and * postmultiplied by diag( DL ) * ('S' for symmetric, or 'H' for Hermitian) * 'E' => matrix premultiplied by diag( DL ) and * postmultiplied by inv( diag( DL ) ) * ( 'E' for eigenvalue invariance) * (only if matrix nonsymmetric) * Note: if GRADE='E', then M must equal N. * Not modified. * * DL - DOUBLE PRECISION array, dimension (M) * If MODEL=0, then on entry this array specifies the diagonal * entries of a diagonal matrix used as described under GRADE * above. If MODEL is not zero, then DL will be set according * to MODEL and CONDL, analogous to the way D is set according * to MODE and COND (except there is no DMAX parameter for DL). * If GRADE='E', then DL cannot have zero entries. * Not referenced if GRADE = 'N' or 'R'. Changed on exit. * * MODEL - INTEGER * This specifies how the diagonal array DL is to be computed, * just as MODE specifies how D is to be computed. * Not modified. * * CONDL - DOUBLE PRECISION * When MODEL is not zero, this specifies the condition number * of the computed DL. Not modified. * * DR - DOUBLE PRECISION array, dimension (N) * If MODER=0, then on entry this array specifies the diagonal * entries of a diagonal matrix used as described under GRADE * above. If MODER is not zero, then DR will be set according * to MODER and CONDR, analogous to the way D is set according * to MODE and COND (except there is no DMAX parameter for DR). * Not referenced if GRADE = 'N', 'L', 'H', 'S' or 'E'. * Changed on exit. * * MODER - INTEGER * This specifies how the diagonal array DR is to be computed, * just as MODE specifies how D is to be computed. * Not modified. * * CONDR - DOUBLE PRECISION * When MODER is not zero, this specifies the condition number * of the computed DR. Not modified. * * PIVTNG - CHARACTER*1 * On entry specifies pivoting permutations as follows: * 'N' or ' ' => none. * 'L' => left or row pivoting (matrix must be nonsymmetric). * 'R' => right or column pivoting (matrix must be * nonsymmetric). * 'B' or 'F' => both or full pivoting, i.e., on both sides. * In this case, M must equal N * * If two calls to DLATMR both have full bandwidth (KL = M-1 * and KU = N-1), and differ only in the PIVTNG and PACK * parameters, then the matrices generated will differ only * in the order of the rows and/or columns, and otherwise * contain the same data. This consistency cannot be * maintained with less than full bandwidth. * * IPIVOT - INTEGER array, dimension (N or M) * This array specifies the permutation used. After the * basic matrix is generated, the rows, columns, or both * are permuted. If, say, row pivoting is selected, DLATMR * starts with the *last* row and interchanges the M-th and * IPIVOT(M)-th rows, then moves to the next-to-last row, * interchanging the (M-1)-th and the IPIVOT(M-1)-th rows, * and so on. In terms of "2-cycles", the permutation is * (1 IPIVOT(1)) (2 IPIVOT(2)) ... (M IPIVOT(M)) * where the rightmost cycle is applied first. This is the * *inverse* of the effect of pivoting in LINPACK. The idea * is that factoring (with pivoting) an identity matrix * which has been inverse-pivoted in this way should * result in a pivot vector identical to IPIVOT. * Not referenced if PIVTNG = 'N'. Not modified. * * SPARSE - DOUBLE PRECISION * On entry specifies the sparsity of the matrix if a sparse * matrix is to be generated. SPARSE should lie between * 0 and 1. To generate a sparse matrix, for each matrix entry * a uniform ( 0, 1 ) random number x is generated and * compared to SPARSE; if x is larger the matrix entry * is unchanged and if x is smaller the entry is set * to zero. Thus on the average a fraction SPARSE of the * entries will be set to zero. * Not modified. * * KL - INTEGER * On entry specifies the lower bandwidth of the matrix. For * example, KL=0 implies upper triangular, KL=1 implies upper * Hessenberg, and KL at least M-1 implies the matrix is not * banded. Must equal KU if matrix is symmetric. * Not modified. * * KU - INTEGER * On entry specifies the upper bandwidth of the matrix. For * example, KU=0 implies lower triangular, KU=1 implies lower * Hessenberg, and KU at least N-1 implies the matrix is not * banded. Must equal KL if matrix is symmetric. * Not modified. * * ANORM - DOUBLE PRECISION * On entry specifies maximum entry of output matrix * (output matrix will by multiplied by a constant so that * its largest absolute entry equal ANORM) * if ANORM is nonnegative. If ANORM is negative no scaling * is done. Not modified. * * PACK - CHARACTER*1 * On entry specifies packing of matrix as follows: * 'N' => no packing * 'U' => zero out all subdiagonal entries (if symmetric) * 'L' => zero out all superdiagonal entries (if symmetric) * 'C' => store the upper triangle columnwise * (only if matrix symmetric or square upper triangular) * 'R' => store the lower triangle columnwise * (only if matrix symmetric or square lower triangular) * (same as upper half rowwise if symmetric) * 'B' => store the lower triangle in band storage scheme * (only if matrix symmetric) * 'Q' => store the upper triangle in band storage scheme * (only if matrix symmetric) * 'Z' => store the entire matrix in band storage scheme * (pivoting can be provided for by using this * option to store A in the trailing rows of * the allocated storage) * * Using these options, the various LAPACK packed and banded * storage schemes can be obtained: * GB - use 'Z' * PB, SB or TB - use 'B' or 'Q' * PP, SP or TP - use 'C' or 'R' * * If two calls to DLATMR differ only in the PACK parameter, * they will generate mathematically equivalent matrices. * Not modified. * * A - DOUBLE PRECISION array, dimension (LDA,N) * On exit A is the desired test matrix. Only those * entries of A which are significant on output * will be referenced (even if A is in packed or band * storage format). The 'unoccupied corners' of A in * band format will be zeroed out. * * LDA - INTEGER * on entry LDA specifies the first dimension of A as * declared in the calling program. * If PACK='N', 'U' or 'L', LDA must be at least max ( 1, M ). * If PACK='C' or 'R', LDA must be at least 1. * If PACK='B', or 'Q', LDA must be MIN ( KU+1, N ) * If PACK='Z', LDA must be at least KUU+KLL+1, where * KUU = MIN ( KU, N-1 ) and KLL = MIN ( KL, N-1 ) * Not modified. * * IWORK - INTEGER array, dimension ( N or M) * Workspace. Not referenced if PIVTNG = 'N'. Changed on exit. * * INFO - INTEGER * Error parameter on exit: * 0 => normal return * -1 => M negative or unequal to N and SYM='S' or 'H' * -2 => N negative * -3 => DIST illegal string * -5 => SYM illegal string * -7 => MODE not in range -6 to 6 * -8 => COND less than 1.0, and MODE neither -6, 0 nor 6 * -10 => MODE neither -6, 0 nor 6 and RSIGN illegal string * -11 => GRADE illegal string, or GRADE='E' and * M not equal to N, or GRADE='L', 'R', 'B' or 'E' and * SYM = 'S' or 'H' * -12 => GRADE = 'E' and DL contains zero * -13 => MODEL not in range -6 to 6 and GRADE= 'L', 'B', 'H', * 'S' or 'E' * -14 => CONDL less than 1.0, GRADE='L', 'B', 'H', 'S' or 'E', * and MODEL neither -6, 0 nor 6 * -16 => MODER not in range -6 to 6 and GRADE= 'R' or 'B' * -17 => CONDR less than 1.0, GRADE='R' or 'B', and * MODER neither -6, 0 nor 6 * -18 => PIVTNG illegal string, or PIVTNG='B' or 'F' and * M not equal to N, or PIVTNG='L' or 'R' and SYM='S' * or 'H' * -19 => IPIVOT contains out of range number and * PIVTNG not equal to 'N' * -20 => KL negative * -21 => KU negative, or SYM='S' or 'H' and KU not equal to KL * -22 => SPARSE not in range 0. to 1. * -24 => PACK illegal string, or PACK='U', 'L', 'B' or 'Q' * and SYM='N', or PACK='C' and SYM='N' and either KL * not equal to 0 or N not equal to M, or PACK='R' and * SYM='N', and either KU not equal to 0 or N not equal * to M * -26 => LDA too small * 1 => Error return from DLATM1 (computing D) * 2 => Cannot scale diagonal to DMAX (max. entry is 0) * 3 => Error return from DLATM1 (computing DL) * 4 => Error return from DLATM1 (computing DR) * 5 => ANORM is positive, but matrix constructed prior to * attempting to scale it to have norm ANORM, is zero * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) * .. * .. Local Scalars .. LOGICAL BADPVT, DZERO, FULBND INTEGER I, IDIST, IGRADE, IISUB, IPACK, IPVTNG, IRSIGN, $ ISUB, ISYM, J, JJSUB, JSUB, K, KLL, KUU, MNMIN, $ MNSUB, MXSUB, NPVTS DOUBLE PRECISION ALPHA, ONORM, TEMP * .. * .. Local Arrays .. DOUBLE PRECISION TEMPA( 1 ) * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLANGB, DLANGE, DLANSB, DLANSP, DLANSY, DLATM2, $ DLATM3 EXTERNAL LSAME, DLANGB, DLANGE, DLANSB, DLANSP, DLANSY, $ DLATM2, DLATM3 * .. * .. External Subroutines .. EXTERNAL DLATM1, DSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, MOD * .. * .. Executable Statements .. * * 1) Decode and Test the input parameters. * Initialize flags & seed. * INFO = 0 * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * * Decode DIST * IF( LSAME( DIST, 'U' ) ) THEN IDIST = 1 ELSE IF( LSAME( DIST, 'S' ) ) THEN IDIST = 2 ELSE IF( LSAME( DIST, 'N' ) ) THEN IDIST = 3 ELSE IDIST = -1 END IF * * Decode SYM * IF( LSAME( SYM, 'S' ) ) THEN ISYM = 0 ELSE IF( LSAME( SYM, 'N' ) ) THEN ISYM = 1 ELSE IF( LSAME( SYM, 'H' ) ) THEN ISYM = 0 ELSE ISYM = -1 END IF * * Decode RSIGN * IF( LSAME( RSIGN, 'F' ) ) THEN IRSIGN = 0 ELSE IF( LSAME( RSIGN, 'T' ) ) THEN IRSIGN = 1 ELSE IRSIGN = -1 END IF * * Decode PIVTNG * IF( LSAME( PIVTNG, 'N' ) ) THEN IPVTNG = 0 ELSE IF( LSAME( PIVTNG, ' ' ) ) THEN IPVTNG = 0 ELSE IF( LSAME( PIVTNG, 'L' ) ) THEN IPVTNG = 1 NPVTS = M ELSE IF( LSAME( PIVTNG, 'R' ) ) THEN IPVTNG = 2 NPVTS = N ELSE IF( LSAME( PIVTNG, 'B' ) ) THEN IPVTNG = 3 NPVTS = MIN( N, M ) ELSE IF( LSAME( PIVTNG, 'F' ) ) THEN IPVTNG = 3 NPVTS = MIN( N, M ) ELSE IPVTNG = -1 END IF * * Decode GRADE * IF( LSAME( GRADE, 'N' ) ) THEN IGRADE = 0 ELSE IF( LSAME( GRADE, 'L' ) ) THEN IGRADE = 1 ELSE IF( LSAME( GRADE, 'R' ) ) THEN IGRADE = 2 ELSE IF( LSAME( GRADE, 'B' ) ) THEN IGRADE = 3 ELSE IF( LSAME( GRADE, 'E' ) ) THEN IGRADE = 4 ELSE IF( LSAME( GRADE, 'H' ) .OR. LSAME( GRADE, 'S' ) ) THEN IGRADE = 5 ELSE IGRADE = -1 END IF * * Decode PACK * IF( LSAME( PACK, 'N' ) ) THEN IPACK = 0 ELSE IF( LSAME( PACK, 'U' ) ) THEN IPACK = 1 ELSE IF( LSAME( PACK, 'L' ) ) THEN IPACK = 2 ELSE IF( LSAME( PACK, 'C' ) ) THEN IPACK = 3 ELSE IF( LSAME( PACK, 'R' ) ) THEN IPACK = 4 ELSE IF( LSAME( PACK, 'B' ) ) THEN IPACK = 5 ELSE IF( LSAME( PACK, 'Q' ) ) THEN IPACK = 6 ELSE IF( LSAME( PACK, 'Z' ) ) THEN IPACK = 7 ELSE IPACK = -1 END IF * * Set certain internal parameters * MNMIN = MIN( M, N ) KLL = MIN( KL, M-1 ) KUU = MIN( KU, N-1 ) * * If inv(DL) is used, check to see if DL has a zero entry. * DZERO = .FALSE. IF( IGRADE.EQ.4 .AND. MODEL.EQ.0 ) THEN DO 10 I = 1, M IF( DL( I ).EQ.ZERO ) $ DZERO = .TRUE. 10 CONTINUE END IF * * Check values in IPIVOT * BADPVT = .FALSE. IF( IPVTNG.GT.0 ) THEN DO 20 J = 1, NPVTS IF( IPIVOT( J ).LE.0 .OR. IPIVOT( J ).GT.NPVTS ) $ BADPVT = .TRUE. 20 CONTINUE END IF * * Set INFO if an error * IF( M.LT.0 ) THEN INFO = -1 ELSE IF( M.NE.N .AND. ISYM.EQ.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( IDIST.EQ.-1 ) THEN INFO = -3 ELSE IF( ISYM.EQ.-1 ) THEN INFO = -5 ELSE IF( MODE.LT.-6 .OR. MODE.GT.6 ) THEN INFO = -7 ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND. $ COND.LT.ONE ) THEN INFO = -8 ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND. $ IRSIGN.EQ.-1 ) THEN INFO = -10 ELSE IF( IGRADE.EQ.-1 .OR. ( IGRADE.EQ.4 .AND. M.NE.N ) .OR. $ ( ( IGRADE.GE.1 .AND. IGRADE.LE.4 ) .AND. ISYM.EQ.0 ) ) $ THEN INFO = -11 ELSE IF( IGRADE.EQ.4 .AND. DZERO ) THEN INFO = -12 ELSE IF( ( IGRADE.EQ.1 .OR. IGRADE.EQ.3 .OR. IGRADE.EQ.4 .OR. $ IGRADE.EQ.5 ) .AND. ( MODEL.LT.-6 .OR. MODEL.GT.6 ) ) $ THEN INFO = -13 ELSE IF( ( IGRADE.EQ.1 .OR. IGRADE.EQ.3 .OR. IGRADE.EQ.4 .OR. $ IGRADE.EQ.5 ) .AND. ( MODEL.NE.-6 .AND. MODEL.NE.0 .AND. $ MODEL.NE.6 ) .AND. CONDL.LT.ONE ) THEN INFO = -14 ELSE IF( ( IGRADE.EQ.2 .OR. IGRADE.EQ.3 ) .AND. $ ( MODER.LT.-6 .OR. MODER.GT.6 ) ) THEN INFO = -16 ELSE IF( ( IGRADE.EQ.2 .OR. IGRADE.EQ.3 ) .AND. $ ( MODER.NE.-6 .AND. MODER.NE.0 .AND. MODER.NE.6 ) .AND. $ CONDR.LT.ONE ) THEN INFO = -17 ELSE IF( IPVTNG.EQ.-1 .OR. ( IPVTNG.EQ.3 .AND. M.NE.N ) .OR. $ ( ( IPVTNG.EQ.1 .OR. IPVTNG.EQ.2 ) .AND. ISYM.EQ.0 ) ) $ THEN INFO = -18 ELSE IF( IPVTNG.NE.0 .AND. BADPVT ) THEN INFO = -19 ELSE IF( KL.LT.0 ) THEN INFO = -20 ELSE IF( KU.LT.0 .OR. ( ISYM.EQ.0 .AND. KL.NE.KU ) ) THEN INFO = -21 ELSE IF( SPARSE.LT.ZERO .OR. SPARSE.GT.ONE ) THEN INFO = -22 ELSE IF( IPACK.EQ.-1 .OR. ( ( IPACK.EQ.1 .OR. IPACK.EQ.2 .OR. $ IPACK.EQ.5 .OR. IPACK.EQ.6 ) .AND. ISYM.EQ.1 ) .OR. $ ( IPACK.EQ.3 .AND. ISYM.EQ.1 .AND. ( KL.NE.0 .OR. M.NE. $ N ) ) .OR. ( IPACK.EQ.4 .AND. ISYM.EQ.1 .AND. ( KU.NE. $ 0 .OR. M.NE.N ) ) ) THEN INFO = -24 ELSE IF( ( ( IPACK.EQ.0 .OR. IPACK.EQ.1 .OR. IPACK.EQ.2 ) .AND. $ LDA.LT.MAX( 1, M ) ) .OR. ( ( IPACK.EQ.3 .OR. IPACK.EQ. $ 4 ) .AND. LDA.LT.1 ) .OR. ( ( IPACK.EQ.5 .OR. IPACK.EQ. $ 6 ) .AND. LDA.LT.KUU+1 ) .OR. $ ( IPACK.EQ.7 .AND. LDA.LT.KLL+KUU+1 ) ) THEN INFO = -26 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLATMR', -INFO ) RETURN END IF * * Decide if we can pivot consistently * FULBND = .FALSE. IF( KUU.EQ.N-1 .AND. KLL.EQ.M-1 ) $ FULBND = .TRUE. * * Initialize random number generator * DO 30 I = 1, 4 ISEED( I ) = MOD( ABS( ISEED( I ) ), 4096 ) 30 CONTINUE * ISEED( 4 ) = 2*( ISEED( 4 ) / 2 ) + 1 * * 2) Set up D, DL, and DR, if indicated. * * Compute D according to COND and MODE * CALL DLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, MNMIN, INFO ) IF( INFO.NE.0 ) THEN INFO = 1 RETURN END IF IF( MODE.NE.0 .AND. MODE.NE.-6 .AND. MODE.NE.6 ) THEN * * Scale by DMAX * TEMP = ABS( D( 1 ) ) DO 40 I = 2, MNMIN TEMP = MAX( TEMP, ABS( D( I ) ) ) 40 CONTINUE IF( TEMP.EQ.ZERO .AND. DMAX.NE.ZERO ) THEN INFO = 2 RETURN END IF IF( TEMP.NE.ZERO ) THEN ALPHA = DMAX / TEMP ELSE ALPHA = ONE END IF DO 50 I = 1, MNMIN D( I ) = ALPHA*D( I ) 50 CONTINUE * END IF * * Compute DL if grading set * IF( IGRADE.EQ.1 .OR. IGRADE.EQ.3 .OR. IGRADE.EQ.4 .OR. IGRADE.EQ. $ 5 ) THEN CALL DLATM1( MODEL, CONDL, 0, IDIST, ISEED, DL, M, INFO ) IF( INFO.NE.0 ) THEN INFO = 3 RETURN END IF END IF * * Compute DR if grading set * IF( IGRADE.EQ.2 .OR. IGRADE.EQ.3 ) THEN CALL DLATM1( MODER, CONDR, 0, IDIST, ISEED, DR, N, INFO ) IF( INFO.NE.0 ) THEN INFO = 4 RETURN END IF END IF * * 3) Generate IWORK if pivoting * IF( IPVTNG.GT.0 ) THEN DO 60 I = 1, NPVTS IWORK( I ) = I 60 CONTINUE IF( FULBND ) THEN DO 70 I = 1, NPVTS K = IPIVOT( I ) J = IWORK( I ) IWORK( I ) = IWORK( K ) IWORK( K ) = J 70 CONTINUE ELSE DO 80 I = NPVTS, 1, -1 K = IPIVOT( I ) J = IWORK( I ) IWORK( I ) = IWORK( K ) IWORK( K ) = J 80 CONTINUE END IF END IF * * 4) Generate matrices for each kind of PACKing * Always sweep matrix columnwise (if symmetric, upper * half only) so that matrix generated does not depend * on PACK * IF( FULBND ) THEN * * Use DLATM3 so matrices generated with differing PIVOTing only * differ only in the order of their rows and/or columns. * IF( IPACK.EQ.0 ) THEN IF( ISYM.EQ.0 ) THEN DO 100 J = 1, N DO 90 I = 1, J TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) A( ISUB, JSUB ) = TEMP A( JSUB, ISUB ) = TEMP 90 CONTINUE 100 CONTINUE ELSE IF( ISYM.EQ.1 ) THEN DO 120 J = 1, N DO 110 I = 1, M TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) A( ISUB, JSUB ) = TEMP 110 CONTINUE 120 CONTINUE END IF * ELSE IF( IPACK.EQ.1 ) THEN * DO 140 J = 1, N DO 130 I = 1, J TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, $ SPARSE ) MNSUB = MIN( ISUB, JSUB ) MXSUB = MAX( ISUB, JSUB ) A( MNSUB, MXSUB ) = TEMP IF( MNSUB.NE.MXSUB ) $ A( MXSUB, MNSUB ) = ZERO 130 CONTINUE 140 CONTINUE * ELSE IF( IPACK.EQ.2 ) THEN * DO 160 J = 1, N DO 150 I = 1, J TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, $ SPARSE ) MNSUB = MIN( ISUB, JSUB ) MXSUB = MAX( ISUB, JSUB ) A( MXSUB, MNSUB ) = TEMP IF( MNSUB.NE.MXSUB ) $ A( MNSUB, MXSUB ) = ZERO 150 CONTINUE 160 CONTINUE * ELSE IF( IPACK.EQ.3 ) THEN * DO 180 J = 1, N DO 170 I = 1, J TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, $ SPARSE ) * * Compute K = location of (ISUB,JSUB) entry in packed * array * MNSUB = MIN( ISUB, JSUB ) MXSUB = MAX( ISUB, JSUB ) K = MXSUB*( MXSUB-1 ) / 2 + MNSUB * * Convert K to (IISUB,JJSUB) location * JJSUB = ( K-1 ) / LDA + 1 IISUB = K - LDA*( JJSUB-1 ) * A( IISUB, JJSUB ) = TEMP 170 CONTINUE 180 CONTINUE * ELSE IF( IPACK.EQ.4 ) THEN * DO 200 J = 1, N DO 190 I = 1, J TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, $ SPARSE ) * * Compute K = location of (I,J) entry in packed array * MNSUB = MIN( ISUB, JSUB ) MXSUB = MAX( ISUB, JSUB ) IF( MNSUB.EQ.1 ) THEN K = MXSUB ELSE K = N*( N+1 ) / 2 - ( N-MNSUB+1 )*( N-MNSUB+2 ) / $ 2 + MXSUB - MNSUB + 1 END IF * * Convert K to (IISUB,JJSUB) location * JJSUB = ( K-1 ) / LDA + 1 IISUB = K - LDA*( JJSUB-1 ) * A( IISUB, JJSUB ) = TEMP 190 CONTINUE 200 CONTINUE * ELSE IF( IPACK.EQ.5 ) THEN * DO 220 J = 1, N DO 210 I = J - KUU, J IF( I.LT.1 ) THEN A( J-I+1, I+N ) = ZERO ELSE TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) MNSUB = MIN( ISUB, JSUB ) MXSUB = MAX( ISUB, JSUB ) A( MXSUB-MNSUB+1, MNSUB ) = TEMP END IF 210 CONTINUE 220 CONTINUE * ELSE IF( IPACK.EQ.6 ) THEN * DO 240 J = 1, N DO 230 I = J - KUU, J TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, $ SPARSE ) MNSUB = MIN( ISUB, JSUB ) MXSUB = MAX( ISUB, JSUB ) A( MNSUB-MXSUB+KUU+1, MXSUB ) = TEMP 230 CONTINUE 240 CONTINUE * ELSE IF( IPACK.EQ.7 ) THEN * IF( ISYM.EQ.0 ) THEN DO 260 J = 1, N DO 250 I = J - KUU, J TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) MNSUB = MIN( ISUB, JSUB ) MXSUB = MAX( ISUB, JSUB ) A( MNSUB-MXSUB+KUU+1, MXSUB ) = TEMP IF( I.LT.1 ) $ A( J-I+1+KUU, I+N ) = ZERO IF( I.GE.1 .AND. MNSUB.NE.MXSUB ) $ A( MXSUB-MNSUB+1+KUU, MNSUB ) = TEMP 250 CONTINUE 260 CONTINUE ELSE IF( ISYM.EQ.1 ) THEN DO 280 J = 1, N DO 270 I = J - KUU, J + KLL TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) A( ISUB-JSUB+KUU+1, JSUB ) = TEMP 270 CONTINUE 280 CONTINUE END IF * END IF * ELSE * * Use DLATM2 * IF( IPACK.EQ.0 ) THEN IF( ISYM.EQ.0 ) THEN DO 300 J = 1, N DO 290 I = 1, J A( I, J ) = DLATM2( M, N, I, J, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) A( J, I ) = A( I, J ) 290 CONTINUE 300 CONTINUE ELSE IF( ISYM.EQ.1 ) THEN DO 320 J = 1, N DO 310 I = 1, M A( I, J ) = DLATM2( M, N, I, J, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) 310 CONTINUE 320 CONTINUE END IF * ELSE IF( IPACK.EQ.1 ) THEN * DO 340 J = 1, N DO 330 I = 1, J A( I, J ) = DLATM2( M, N, I, J, KL, KU, IDIST, ISEED, $ D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE ) IF( I.NE.J ) $ A( J, I ) = ZERO 330 CONTINUE 340 CONTINUE * ELSE IF( IPACK.EQ.2 ) THEN * DO 360 J = 1, N DO 350 I = 1, J A( J, I ) = DLATM2( M, N, I, J, KL, KU, IDIST, ISEED, $ D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE ) IF( I.NE.J ) $ A( I, J ) = ZERO 350 CONTINUE 360 CONTINUE * ELSE IF( IPACK.EQ.3 ) THEN * ISUB = 0 JSUB = 1 DO 380 J = 1, N DO 370 I = 1, J ISUB = ISUB + 1 IF( ISUB.GT.LDA ) THEN ISUB = 1 JSUB = JSUB + 1 END IF A( ISUB, JSUB ) = DLATM2( M, N, I, J, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) 370 CONTINUE 380 CONTINUE * ELSE IF( IPACK.EQ.4 ) THEN * IF( ISYM.EQ.0 ) THEN DO 400 J = 1, N DO 390 I = 1, J * * Compute K = location of (I,J) entry in packed array * IF( I.EQ.1 ) THEN K = J ELSE K = N*( N+1 ) / 2 - ( N-I+1 )*( N-I+2 ) / 2 + $ J - I + 1 END IF * * Convert K to (ISUB,JSUB) location * JSUB = ( K-1 ) / LDA + 1 ISUB = K - LDA*( JSUB-1 ) * A( ISUB, JSUB ) = DLATM2( M, N, I, J, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, DR, $ IPVTNG, IWORK, SPARSE ) 390 CONTINUE 400 CONTINUE ELSE ISUB = 0 JSUB = 1 DO 420 J = 1, N DO 410 I = J, M ISUB = ISUB + 1 IF( ISUB.GT.LDA ) THEN ISUB = 1 JSUB = JSUB + 1 END IF A( ISUB, JSUB ) = DLATM2( M, N, I, J, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, DR, $ IPVTNG, IWORK, SPARSE ) 410 CONTINUE 420 CONTINUE END IF * ELSE IF( IPACK.EQ.5 ) THEN * DO 440 J = 1, N DO 430 I = J - KUU, J IF( I.LT.1 ) THEN A( J-I+1, I+N ) = ZERO ELSE A( J-I+1, I ) = DLATM2( M, N, I, J, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) END IF 430 CONTINUE 440 CONTINUE * ELSE IF( IPACK.EQ.6 ) THEN * DO 460 J = 1, N DO 450 I = J - KUU, J A( I-J+KUU+1, J ) = DLATM2( M, N, I, J, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) 450 CONTINUE 460 CONTINUE * ELSE IF( IPACK.EQ.7 ) THEN * IF( ISYM.EQ.0 ) THEN DO 480 J = 1, N DO 470 I = J - KUU, J A( I-J+KUU+1, J ) = DLATM2( M, N, I, J, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, $ DR, IPVTNG, IWORK, SPARSE ) IF( I.LT.1 ) $ A( J-I+1+KUU, I+N ) = ZERO IF( I.GE.1 .AND. I.NE.J ) $ A( J-I+1+KUU, I ) = A( I-J+KUU+1, J ) 470 CONTINUE 480 CONTINUE ELSE IF( ISYM.EQ.1 ) THEN DO 500 J = 1, N DO 490 I = J - KUU, J + KLL A( I-J+KUU+1, J ) = DLATM2( M, N, I, J, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, $ DR, IPVTNG, IWORK, SPARSE ) 490 CONTINUE 500 CONTINUE END IF * END IF * END IF * * 5) Scaling the norm * IF( IPACK.EQ.0 ) THEN ONORM = DLANGE( 'M', M, N, A, LDA, TEMPA ) ELSE IF( IPACK.EQ.1 ) THEN ONORM = DLANSY( 'M', 'U', N, A, LDA, TEMPA ) ELSE IF( IPACK.EQ.2 ) THEN ONORM = DLANSY( 'M', 'L', N, A, LDA, TEMPA ) ELSE IF( IPACK.EQ.3 ) THEN ONORM = DLANSP( 'M', 'U', N, A, TEMPA ) ELSE IF( IPACK.EQ.4 ) THEN ONORM = DLANSP( 'M', 'L', N, A, TEMPA ) ELSE IF( IPACK.EQ.5 ) THEN ONORM = DLANSB( 'M', 'L', N, KLL, A, LDA, TEMPA ) ELSE IF( IPACK.EQ.6 ) THEN ONORM = DLANSB( 'M', 'U', N, KUU, A, LDA, TEMPA ) ELSE IF( IPACK.EQ.7 ) THEN ONORM = DLANGB( 'M', N, KLL, KUU, A, LDA, TEMPA ) END IF * IF( ANORM.GE.ZERO ) THEN * IF( ANORM.GT.ZERO .AND. ONORM.EQ.ZERO ) THEN * * Desired scaling impossible * INFO = 5 RETURN * ELSE IF( ( ANORM.GT.ONE .AND. ONORM.LT.ONE ) .OR. $ ( ANORM.LT.ONE .AND. ONORM.GT.ONE ) ) THEN * * Scale carefully to avoid over / underflow * IF( IPACK.LE.2 ) THEN DO 510 J = 1, N CALL DSCAL( M, ONE / ONORM, A( 1, J ), 1 ) CALL DSCAL( M, ANORM, A( 1, J ), 1 ) 510 CONTINUE * ELSE IF( IPACK.EQ.3 .OR. IPACK.EQ.4 ) THEN * CALL DSCAL( N*( N+1 ) / 2, ONE / ONORM, A, 1 ) CALL DSCAL( N*( N+1 ) / 2, ANORM, A, 1 ) * ELSE IF( IPACK.GE.5 ) THEN * DO 520 J = 1, N CALL DSCAL( KLL+KUU+1, ONE / ONORM, A( 1, J ), 1 ) CALL DSCAL( KLL+KUU+1, ANORM, A( 1, J ), 1 ) 520 CONTINUE * END IF * ELSE * * Scale straightforwardly * IF( IPACK.LE.2 ) THEN DO 530 J = 1, N CALL DSCAL( M, ANORM / ONORM, A( 1, J ), 1 ) 530 CONTINUE * ELSE IF( IPACK.EQ.3 .OR. IPACK.EQ.4 ) THEN * CALL DSCAL( N*( N+1 ) / 2, ANORM / ONORM, A, 1 ) * ELSE IF( IPACK.GE.5 ) THEN * DO 540 J = 1, N CALL DSCAL( KLL+KUU+1, ANORM / ONORM, A( 1, J ), 1 ) 540 CONTINUE END IF * END IF * END IF * * End of DLATMR * END SHAR_EOF fi # end of overwriting check if test -f 'dlatms.f' then echo shar: will not over-write existing file "'dlatms.f'" else cat << SHAR_EOF > 'dlatms.f' SUBROUTINE DLATMS( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, $ KL, KU, PACK, A, LDA, WORK, INFO ) * * -- LAPACK test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER DIST, PACK, SYM INTEGER INFO, KL, KU, LDA, M, MODE, N DOUBLE PRECISION COND, DMAX * .. * .. Array Arguments .. INTEGER ISEED( 4 ) DOUBLE PRECISION A( LDA, * ), D( * ), WORK( * ) * .. * * Purpose * ======= * * DLATMS generates random matrices with specified singular values * (or symmetric/hermitian with specified eigenvalues) * for testing LAPACK programs. * * DLATMS operates by applying the following sequence of * operations: * * Set the diagonal to D, where D may be input or * computed according to MODE, COND, DMAX, and SYM * as described below. * * Generate a matrix with the appropriate band structure, by one * of two methods: * * Method A: * Generate a dense M x N matrix by multiplying D on the left * and the right by random unitary matrices, then: * * Reduce the bandwidth according to KL and KU, using * Householder transformations. * * Method B: * Convert the bandwidth-0 (i.e., diagonal) matrix to a * bandwidth-1 matrix using Givens rotations, "chasing" * out-of-band elements back, much as in QR; then * convert the bandwidth-1 to a bandwidth-2 matrix, etc. * Note that for reasonably small bandwidths (relative to * M and N) this requires less storage, as a dense matrix * is not generated. Also, for symmetric matrices, only * one triangle is generated. * * Method A is chosen if the bandwidth is a large fraction of the * order of the matrix, and LDA is at least M (so a dense * matrix can be stored.) Method B is chosen if the bandwidth * is small (< 1/2 N for symmetric, < .3 N+M for * non-symmetric), or LDA is less than M and not less than the * bandwidth. * * Pack the matrix if desired. Options specified by PACK are: * no packing * zero out upper half (if symmetric) * zero out lower half (if symmetric) * store the upper half columnwise (if symmetric or upper * triangular) * store the lower half columnwise (if symmetric or lower * triangular) * store the lower triangle in banded format (if symmetric * or lower triangular) * store the upper triangle in banded format (if symmetric * or upper triangular) * store the entire matrix in banded format * If Method B is chosen, and band format is specified, then the * matrix will be generated in the band format, so no repacking * will be necessary. * * Arguments * ========= * * M - INTEGER * The number of rows of A. Not modified. * * N - INTEGER * The number of columns of A. Not modified. * * DIST - CHARACTER*1 * On entry, DIST specifies the type of distribution to be used * to generate the random eigen-/singular values. * 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) * 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) * 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) * Not modified. * * ISEED - INTEGER array, dimension ( 4 ) * On entry ISEED specifies the seed of the random number * generator. They should lie between 0 and 4095 inclusive, * and ISEED(4) should be odd. The random number generator * uses a linear congruential sequence limited to small * integers, and so should produce machine independent * random numbers. The values of ISEED are changed on * exit, and can be used in the next call to DLATMS * to continue the same random number sequence. * Changed on exit. * * SYM - CHARACTER*1 * If SYM='S' or 'H', the generated matrix is symmetric, with * eigenvalues specified by D, COND, MODE, and DMAX; they * may be positive, negative, or zero. * If SYM='P', the generated matrix is symmetric, with * eigenvalues (= singular values) specified by D, COND, * MODE, and DMAX; they will not be negative. * If SYM='N', the generated matrix is nonsymmetric, with * singular values specified by D, COND, MODE, and DMAX; * they will not be negative. * Not modified. * * D - DOUBLE PRECISION array, dimension ( MIN( M , N ) ) * This array is used to specify the singular values or * eigenvalues of A (see SYM, above.) If MODE=0, then D is * assumed to contain the singular/eigenvalues, otherwise * they will be computed according to MODE, COND, and DMAX, * and placed in D. * Modified if MODE is nonzero. * * MODE - INTEGER * On entry this describes how the singular/eigenvalues are to * be specified: * MODE = 0 means use D as input * MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND * MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND * MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) * MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) * MODE = 5 sets D to random numbers in the range * ( 1/COND , 1 ) such that their logarithms * are uniformly distributed. * MODE = 6 set D to random numbers from same distribution * as the rest of the matrix. * MODE < 0 has the same meaning as ABS(MODE), except that * the order of the elements of D is reversed. * Thus if MODE is positive, D has entries ranging from * 1 to 1/COND, if negative, from 1/COND to 1, * If SYM='S' or 'H', and MODE is neither 0, 6, nor -6, then * the elements of D will also be multiplied by a random * sign (i.e., +1 or -1.) * Not modified. * * COND - DOUBLE PRECISION * On entry, this is used as described under MODE above. * If used, it must be >= 1. Not modified. * * DMAX - DOUBLE PRECISION * If MODE is neither -6, 0 nor 6, the contents of D, as * computed according to MODE and COND, will be scaled by * DMAX / max(abs(D(i))); thus, the maximum absolute eigen- or * singular value (which is to say the norm) will be abs(DMAX). * Note that DMAX need not be positive: if DMAX is negative * (or zero), D will be scaled by a negative number (or zero). * Not modified. * * KL - INTEGER * This specifies the lower bandwidth of the matrix. For * example, KL=0 implies upper triangular, KL=1 implies upper * Hessenberg, and KL being at least M-1 means that the matrix * has full lower bandwidth. KL must equal KU if the matrix * is symmetric. * Not modified. * * KU - INTEGER * This specifies the upper bandwidth of the matrix. For * example, KU=0 implies lower triangular, KU=1 implies lower * Hessenberg, and KU being at least N-1 means that the matrix * has full upper bandwidth. KL must equal KU if the matrix * is symmetric. * Not modified. * * PACK - CHARACTER*1 * This specifies packing of matrix as follows: * 'N' => no packing * 'U' => zero out all subdiagonal entries (if symmetric) * 'L' => zero out all superdiagonal entries (if symmetric) * 'C' => store the upper triangle columnwise * (only if the matrix is symmetric or upper triangular) * 'R' => store the lower triangle columnwise * (only if the matrix is symmetric or lower triangular) * 'B' => store the lower triangle in band storage scheme * (only if matrix symmetric or lower triangular) * 'Q' => store the upper triangle in band storage scheme * (only if matrix symmetric or upper triangular) * 'Z' => store the entire matrix in band storage scheme * (pivoting can be provided for by using this * option to store A in the trailing rows of * the allocated storage) * * Using these options, the various LAPACK packed and banded * storage schemes can be obtained: * GB - use 'Z' * PB, SB or TB - use 'B' or 'Q' * PP, SP or TP - use 'C' or 'R' * * If two calls to DLATMS differ only in the PACK parameter, * they will generate mathematically equivalent matrices. * Not modified. * * A - DOUBLE PRECISION array, dimension ( LDA, N ) * On exit A is the desired test matrix. A is first generated * in full (unpacked) form, and then packed, if so specified * by PACK. Thus, the first M elements of the first N * columns will always be modified. If PACK specifies a * packed or banded storage scheme, all LDA elements of the * first N columns will be modified; the elements of the * array which do not correspond to elements of the generated * matrix are set to zero. * Modified. * * LDA - INTEGER * LDA specifies the first dimension of A as declared in the * calling program. If PACK='N', 'U', 'L', 'C', or 'R', then * LDA must be at least M. If PACK='B' or 'Q', then LDA must * be at least MIN( KL, M-1) (which is equal to MIN(KU,N-1)). * If PACK='Z', LDA must be large enough to hold the packed * array: MIN( KU, N-1) + MIN( KL, M-1) + 1. * Not modified. * * WORK - DOUBLE PRECISION array, dimension ( 3*MAX( N , M ) ) * Workspace. * Modified. * * INFO - INTEGER * Error code. On exit, INFO will be set to one of the * following values: * 0 => normal return * -1 => M negative or unequal to N and SYM='S', 'H', or 'P' * -2 => N negative * -3 => DIST illegal string * -5 => SYM illegal string * -7 => MODE not in range -6 to 6 * -8 => COND less than 1.0, and MODE neither -6, 0 nor 6 * -10 => KL negative * -11 => KU negative, or SYM='S' or 'H' and KU not equal to KL * -12 => PACK illegal string, or PACK='U' or 'L', and SYM='N'; * or PACK='C' or 'Q' and SYM='N' and KL is not zero; * or PACK='R' or 'B' and SYM='N' and KU is not zero; * or PACK='U', 'L', 'C', 'R', 'B', or 'Q', and M is not * N. * -14 => LDA is less than M, or PACK='Z' and LDA is less than * MIN(KU,N-1) + MIN(KL,M-1) + 1. * 1 => Error return from DLATM1 * 2 => Cannot scale to DMAX (max. sing. value is 0) * 3 => Error return from DLAGGE or SLAGSY * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) DOUBLE PRECISION TWOPI PARAMETER ( TWOPI = 6.2831853071795864769252867663D+0 ) * .. * .. Local Scalars .. LOGICAL GIVENS, ILEXTR, ILTEMP, TOPDWN INTEGER I, IC, ICOL, IDIST, IENDCH, IINFO, IL, ILDA, $ IOFFG, IOFFST, IPACK, IPACKG, IR, IR1, IR2, $ IROW, IRSIGN, ISKEW, ISYM, ISYMPK, J, JC, JCH, $ JKL, JKU, JR, K, LLB, MINLDA, MNMIN, MR, NC, $ UUB DOUBLE PRECISION ALPHA, ANGLE, C, DUMMY, EXTRA, S, TEMP * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLARND EXTERNAL LSAME, DLARND * .. * .. External Subroutines .. EXTERNAL DCOPY, DLAGGE, DLAGSY, DLAROT, DLARTG, DLASET, $ DLATM1, DSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, COS, DBLE, MAX, MIN, MOD, SIN * .. * .. Executable Statements .. * * 1) Decode and Test the input parameters. * Initialize flags & seed. * INFO = 0 * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * * Decode DIST * IF( LSAME( DIST, 'U' ) ) THEN IDIST = 1 ELSE IF( LSAME( DIST, 'S' ) ) THEN IDIST = 2 ELSE IF( LSAME( DIST, 'N' ) ) THEN IDIST = 3 ELSE IDIST = -1 END IF * * Decode SYM * IF( LSAME( SYM, 'N' ) ) THEN ISYM = 1 IRSIGN = 0 ELSE IF( LSAME( SYM, 'P' ) ) THEN ISYM = 2 IRSIGN = 0 ELSE IF( LSAME( SYM, 'S' ) ) THEN ISYM = 2 IRSIGN = 1 ELSE IF( LSAME( SYM, 'H' ) ) THEN ISYM = 2 IRSIGN = 1 ELSE ISYM = -1 END IF * * Decode PACK * ISYMPK = 0 IF( LSAME( PACK, 'N' ) ) THEN IPACK = 0 ELSE IF( LSAME( PACK, 'U' ) ) THEN IPACK = 1 ISYMPK = 1 ELSE IF( LSAME( PACK, 'L' ) ) THEN IPACK = 2 ISYMPK = 1 ELSE IF( LSAME( PACK, 'C' ) ) THEN IPACK = 3 ISYMPK = 2 ELSE IF( LSAME( PACK, 'R' ) ) THEN IPACK = 4 ISYMPK = 3 ELSE IF( LSAME( PACK, 'B' ) ) THEN IPACK = 5 ISYMPK = 3 ELSE IF( LSAME( PACK, 'Q' ) ) THEN IPACK = 6 ISYMPK = 2 ELSE IF( LSAME( PACK, 'Z' ) ) THEN IPACK = 7 ELSE IPACK = -1 END IF * * Set certain internal parameters * MNMIN = MIN( M, N ) LLB = MIN( KL, M-1 ) UUB = MIN( KU, N-1 ) MR = MIN( M, N+LLB ) NC = MIN( N, M+UUB ) * IF( IPACK.EQ.5 .OR. IPACK.EQ.6 ) THEN MINLDA = UUB + 1 ELSE IF( IPACK.EQ.7 ) THEN MINLDA = LLB + UUB + 1 ELSE MINLDA = M END IF * * Use Givens rotation method if bandwidth small enough, * or if LDA is too small to store the matrix unpacked. * GIVENS = .FALSE. IF( ISYM.EQ.1 ) THEN IF( DBLE( LLB+UUB ).LT.0.3D0*DBLE( MAX( 1, MR+NC ) ) ) $ GIVENS = .TRUE. ELSE IF( 2*LLB.LT.M ) $ GIVENS = .TRUE. END IF IF( LDA.LT.M .AND. LDA.GE.MINLDA ) $ GIVENS = .TRUE. * * Set INFO if an error * IF( M.LT.0 ) THEN INFO = -1 ELSE IF( M.NE.N .AND. ISYM.NE.1 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( IDIST.EQ.-1 ) THEN INFO = -3 ELSE IF( ISYM.EQ.-1 ) THEN INFO = -5 ELSE IF( ABS( MODE ).GT.6 ) THEN INFO = -7 ELSE IF( ( MODE.NE.0 .AND. ABS( MODE ).NE.6 ) .AND. COND.LT.ONE ) $ THEN INFO = -8 ELSE IF( KL.LT.0 ) THEN INFO = -10 ELSE IF( KU.LT.0 .OR. ( ISYM.NE.1 .AND. KL.NE.KU ) ) THEN INFO = -11 ELSE IF( IPACK.EQ.-1 .OR. ( ISYMPK.EQ.1 .AND. ISYM.EQ.1 ) .OR. $ ( ISYMPK.EQ.2 .AND. ISYM.EQ.1 .AND. KL.GT.0 ) .OR. $ ( ISYMPK.EQ.3 .AND. ISYM.EQ.1 .AND. KU.GT.0 ) .OR. $ ( ISYMPK.NE.0 .AND. M.NE.N ) ) THEN INFO = -12 ELSE IF( LDA.LT.MAX( 1, MINLDA ) ) THEN INFO = -14 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLATMS', -INFO ) RETURN END IF * * Initialize random number generator * DO 10 I = 1, 4 ISEED( I ) = MOD( ABS( ISEED( I ) ), 4096 ) 10 CONTINUE * IF( MOD( ISEED( 4 ), 2 ).NE.1 ) $ ISEED( 4 ) = ISEED( 4 ) + 1 * * 2) Set up D if indicated. * * Compute D according to COND and MODE * CALL DLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, MNMIN, IINFO ) IF( IINFO.NE.0 ) THEN INFO = 1 RETURN END IF * * Choose Top-Down if D is (apparently) increasing, * Bottom-Up if D is (apparently) decreasing. * IF( ABS( D( 1 ) ).LE.ABS( D( MNMIN ) ) ) THEN TOPDWN = .TRUE. ELSE TOPDWN = .FALSE. END IF * IF( MODE.NE.0 .AND. ABS( MODE ).NE.6 ) THEN * * Scale by DMAX * TEMP = ABS( D( 1 ) ) DO 20 I = 2, MNMIN TEMP = MAX( TEMP, ABS( D( I ) ) ) 20 CONTINUE * IF( TEMP.GT.ZERO ) THEN ALPHA = DMAX / TEMP ELSE INFO = 2 RETURN END IF * CALL DSCAL( MNMIN, ALPHA, D, 1 ) * END IF * * 3) Generate Banded Matrix using Givens rotations. * Also the special case of UUB=LLB=0 * * Compute Addressing constants to cover all * storage formats. Whether GE, SY, GB, or SB, * upper or lower triangle or both, * the (i,j)-th element is in * A( i - ISKEW*j + IOFFST, j ) * IF( IPACK.GT.4 ) THEN ILDA = LDA - 1 ISKEW = 1 IF( IPACK.GT.5 ) THEN IOFFST = UUB + 1 ELSE IOFFST = 1 END IF ELSE ILDA = LDA ISKEW = 0 IOFFST = 0 END IF * * IPACKG is the format that the matrix is generated in. If this is * different from IPACK, then the matrix must be repacked at the * end. It also signals how to compute the norm, for scaling. * IPACKG = 0 CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA ) * * Diagonal Matrix -- We are done, unless it * is to be stored SP/PP/TP (PACK='R' or 'C') * IF( LLB.EQ.0 .AND. UUB.EQ.0 ) THEN CALL DCOPY( MNMIN, D, 1, A( 1-ISKEW+IOFFST, 1 ), ILDA+1 ) IF( IPACK.LE.2 .OR. IPACK.GE.5 ) $ IPACKG = IPACK * ELSE IF( GIVENS ) THEN * * Check whether to use Givens rotations, * Householder transformations, or nothing. * IF( ISYM.EQ.1 ) THEN * * Non-symmetric -- A = U D V * IF( IPACK.GT.4 ) THEN IPACKG = IPACK ELSE IPACKG = 0 END IF * CALL DCOPY( MNMIN, D, 1, A( 1-ISKEW+IOFFST, 1 ), ILDA+1 ) * IF( TOPDWN ) THEN JKL = 0 DO 50 JKU = 1, UUB * * Transform from bandwidth JKL, JKU-1 to JKL, JKU * * Last row actually rotated is M * Last column actually rotated is MIN( M+JKU, N ) * DO 40 JR = 1, MIN( M+JKU, N ) + JKL - 1 EXTRA = ZERO ANGLE = TWOPI*DLARND( 1, ISEED ) C = COS( ANGLE ) S = SIN( ANGLE ) ICOL = MAX( 1, JR-JKL ) IF( JR.LT.M ) THEN IL = MIN( N, JR+JKU ) + 1 - ICOL CALL DLAROT( .TRUE., JR.GT.JKL, .FALSE., IL, C, $ S, A( JR-ISKEW*ICOL+IOFFST, ICOL ), $ ILDA, EXTRA, DUMMY ) END IF * * Chase "EXTRA" back up * IR = JR IC = ICOL DO 30 JCH = JR - JKL, 1, -JKL - JKU IF( IR.LT.M ) THEN CALL DLARTG( A( IR+1-ISKEW*( IC+1 )+IOFFST, $ IC+1 ), EXTRA, C, S, DUMMY ) END IF IROW = MAX( 1, JCH-JKU ) IL = IR + 2 - IROW TEMP = ZERO ILTEMP = JCH.GT.JKU CALL DLAROT( .FALSE., ILTEMP, .TRUE., IL, C, -S, $ A( IROW-ISKEW*IC+IOFFST, IC ), $ ILDA, TEMP, EXTRA ) IF( ILTEMP ) THEN CALL DLARTG( A( IROW+1-ISKEW*( IC+1 )+IOFFST, $ IC+1 ), TEMP, C, S, DUMMY ) ICOL = MAX( 1, JCH-JKU-JKL ) IL = IC + 2 - ICOL EXTRA = ZERO CALL DLAROT( .TRUE., JCH.GT.JKU+JKL, .TRUE., $ IL, C, -S, A( IROW-ISKEW*ICOL+ $ IOFFST, ICOL ), ILDA, EXTRA, $ TEMP ) IC = ICOL IR = IROW END IF 30 CONTINUE 40 CONTINUE 50 CONTINUE * JKU = UUB DO 80 JKL = 1, LLB * * Transform from bandwidth JKL-1, JKU to JKL, JKU * DO 70 JC = 1, MIN( N+JKL, M ) + JKU - 1 EXTRA = ZERO ANGLE = TWOPI*DLARND( 1, ISEED ) C = COS( ANGLE ) S = SIN( ANGLE ) IROW = MAX( 1, JC-JKU ) IF( JC.LT.N ) THEN IL = MIN( M, JC+JKL ) + 1 - IROW CALL DLAROT( .FALSE., JC.GT.JKU, .FALSE., IL, C, $ S, A( IROW-ISKEW*JC+IOFFST, JC ), $ ILDA, EXTRA, DUMMY ) END IF * * Chase "EXTRA" back up * IC = JC IR = IROW DO 60 JCH = JC - JKU, 1, -JKL - JKU IF( IC.LT.N ) THEN CALL DLARTG( A( IR+1-ISKEW*( IC+1 )+IOFFST, $ IC+1 ), EXTRA, C, S, DUMMY ) END IF ICOL = MAX( 1, JCH-JKL ) IL = IC + 2 - ICOL TEMP = ZERO ILTEMP = JCH.GT.JKL CALL DLAROT( .TRUE., ILTEMP, .TRUE., IL, C, -S, $ A( IR-ISKEW*ICOL+IOFFST, ICOL ), $ ILDA, TEMP, EXTRA ) IF( ILTEMP ) THEN CALL DLARTG( A( IR+1-ISKEW*( ICOL+1 )+IOFFST, $ ICOL+1 ), TEMP, C, S, DUMMY ) IROW = MAX( 1, JCH-JKL-JKU ) IL = IR + 2 - IROW EXTRA = ZERO CALL DLAROT( .FALSE., JCH.GT.JKL+JKU, .TRUE., $ IL, C, -S, A( IROW-ISKEW*ICOL+ $ IOFFST, ICOL ), ILDA, EXTRA, $ TEMP ) IC = ICOL IR = IROW END IF 60 CONTINUE 70 CONTINUE 80 CONTINUE * ELSE * * Bottom-Up -- Start at the bottom right. * JKL = 0 DO 110 JKU = 1, UUB * * Transform from bandwidth JKL, JKU-1 to JKL, JKU * * First row actually rotated is M * First column actually rotated is MIN( M+JKU, N ) * IENDCH = MIN( M, N+JKL ) - 1 DO 100 JC = MIN( M+JKU, N ) - 1, 1 - JKL, -1 EXTRA = ZERO ANGLE = TWOPI*DLARND( 1, ISEED ) C = COS( ANGLE ) S = SIN( ANGLE ) IROW = MAX( 1, JC-JKU+1 ) IF( JC.GT.0 ) THEN IL = MIN( M, JC+JKL+1 ) + 1 - IROW CALL DLAROT( .FALSE., .FALSE., JC+JKL.LT.M, IL, $ C, S, A( IROW-ISKEW*JC+IOFFST, $ JC ), ILDA, DUMMY, EXTRA ) END IF * * Chase "EXTRA" back down * IC = JC DO 90 JCH = JC + JKL, IENDCH, JKL + JKU ILEXTR = IC.GT.0 IF( ILEXTR ) THEN CALL DLARTG( A( JCH-ISKEW*IC+IOFFST, IC ), $ EXTRA, C, S, DUMMY ) END IF IC = MAX( 1, IC ) ICOL = MIN( N-1, JCH+JKU ) ILTEMP = JCH + JKU.LT.N TEMP = ZERO CALL DLAROT( .TRUE., ILEXTR, ILTEMP, ICOL+2-IC, $ C, S, A( JCH-ISKEW*IC+IOFFST, IC ), $ ILDA, EXTRA, TEMP ) IF( ILTEMP ) THEN CALL DLARTG( A( JCH-ISKEW*ICOL+IOFFST, $ ICOL ), TEMP, C, S, DUMMY ) IL = MIN( IENDCH, JCH+JKL+JKU ) + 2 - JCH EXTRA = ZERO CALL DLAROT( .FALSE., .TRUE., $ JCH+JKL+JKU.LE.IENDCH, IL, C, S, $ A( JCH-ISKEW*ICOL+IOFFST, $ ICOL ), ILDA, TEMP, EXTRA ) IC = ICOL END IF 90 CONTINUE 100 CONTINUE 110 CONTINUE * JKU = UUB DO 140 JKL = 1, LLB * * Transform from bandwidth JKL-1, JKU to JKL, JKU * * First row actually rotated is MIN( N+JKL, M ) * First column actually rotated is N * IENDCH = MIN( N, M+JKU ) - 1 DO 130 JR = MIN( N+JKL, M ) - 1, 1 - JKU, -1 EXTRA = ZERO ANGLE = TWOPI*DLARND( 1, ISEED ) C = COS( ANGLE ) S = SIN( ANGLE ) ICOL = MAX( 1, JR-JKL+1 ) IF( JR.GT.0 ) THEN IL = MIN( N, JR+JKU+1 ) + 1 - ICOL CALL DLAROT( .TRUE., .FALSE., JR+JKU.LT.N, IL, $ C, S, A( JR-ISKEW*ICOL+IOFFST, $ ICOL ), ILDA, DUMMY, EXTRA ) END IF * * Chase "EXTRA" back down * IR = JR DO 120 JCH = JR + JKU, IENDCH, JKL + JKU ILEXTR = IR.GT.0 IF( ILEXTR ) THEN CALL DLARTG( A( IR-ISKEW*JCH+IOFFST, JCH ), $ EXTRA, C, S, DUMMY ) END IF IR = MAX( 1, IR ) IROW = MIN( M-1, JCH+JKL ) ILTEMP = JCH + JKL.LT.M TEMP = ZERO CALL DLAROT( .FALSE., ILEXTR, ILTEMP, IROW+2-IR, $ C, S, A( IR-ISKEW*JCH+IOFFST, $ JCH ), ILDA, EXTRA, TEMP ) IF( ILTEMP ) THEN CALL DLARTG( A( IROW-ISKEW*JCH+IOFFST, JCH ), $ TEMP, C, S, DUMMY ) IL = MIN( IENDCH, JCH+JKL+JKU ) + 2 - JCH EXTRA = ZERO CALL DLAROT( .TRUE., .TRUE., $ JCH+JKL+JKU.LE.IENDCH, IL, C, S, $ A( IROW-ISKEW*JCH+IOFFST, JCH ), $ ILDA, TEMP, EXTRA ) IR = IROW END IF 120 CONTINUE 130 CONTINUE 140 CONTINUE END IF * ELSE * * Symmetric -- A = U D U' * IPACKG = IPACK IOFFG = IOFFST * IF( TOPDWN ) THEN * * Top-Down -- Generate Upper triangle only * IF( IPACK.GE.5 ) THEN IPACKG = 6 IOFFG = UUB + 1 ELSE IPACKG = 1 END IF CALL DCOPY( MNMIN, D, 1, A( 1-ISKEW+IOFFG, 1 ), ILDA+1 ) * DO 170 K = 1, UUB DO 160 JC = 1, N - 1 IROW = MAX( 1, JC-K ) IL = MIN( JC+1, K+2 ) EXTRA = ZERO TEMP = A( JC-ISKEW*( JC+1 )+IOFFG, JC+1 ) ANGLE = TWOPI*DLARND( 1, ISEED ) C = COS( ANGLE ) S = SIN( ANGLE ) CALL DLAROT( .FALSE., JC.GT.K, .TRUE., IL, C, S, $ A( IROW-ISKEW*JC+IOFFG, JC ), ILDA, $ EXTRA, TEMP ) CALL DLAROT( .TRUE., .TRUE., .FALSE., $ MIN( K, N-JC )+1, C, S, $ A( ( 1-ISKEW )*JC+IOFFG, JC ), ILDA, $ TEMP, DUMMY ) * * Chase EXTRA back up the matrix * ICOL = JC DO 150 JCH = JC - K, 1, -K CALL DLARTG( A( JCH+1-ISKEW*( ICOL+1 )+IOFFG, $ ICOL+1 ), EXTRA, C, S, DUMMY ) TEMP = A( JCH-ISKEW*( JCH+1 )+IOFFG, JCH+1 ) CALL DLAROT( .TRUE., .TRUE., .TRUE., K+2, C, -S, $ A( ( 1-ISKEW )*JCH+IOFFG, JCH ), $ ILDA, TEMP, EXTRA ) IROW = MAX( 1, JCH-K ) IL = MIN( JCH+1, K+2 ) EXTRA = ZERO CALL DLAROT( .FALSE., JCH.GT.K, .TRUE., IL, C, $ -S, A( IROW-ISKEW*JCH+IOFFG, JCH ), $ ILDA, EXTRA, TEMP ) ICOL = JCH 150 CONTINUE 160 CONTINUE 170 CONTINUE * * If we need lower triangle, copy from upper. Note that * the order of copying is chosen to work for 'q' -> 'b' * IF( IPACK.NE.IPACKG .AND. IPACK.NE.3 ) THEN DO 190 JC = 1, N IROW = IOFFST - ISKEW*JC DO 180 JR = JC, MIN( N, JC+UUB ) A( JR+IROW, JC ) = A( JC-ISKEW*JR+IOFFG, JR ) 180 CONTINUE 190 CONTINUE IF( IPACK.EQ.5 ) THEN DO 210 JC = N - UUB + 1, N DO 200 JR = N + 2 - JC, UUB + 1 A( JR, JC ) = ZERO 200 CONTINUE 210 CONTINUE END IF IF( IPACKG.EQ.6 ) THEN IPACKG = IPACK ELSE IPACKG = 0 END IF END IF ELSE * * Bottom-Up -- Generate Lower triangle only * IF( IPACK.GE.5 ) THEN IPACKG = 5 IF( IPACK.EQ.6 ) $ IOFFG = 1 ELSE IPACKG = 2 END IF CALL DCOPY( MNMIN, D, 1, A( 1-ISKEW+IOFFG, 1 ), ILDA+1 ) * DO 240 K = 1, UUB DO 230 JC = N - 1, 1, -1 IL = MIN( N+1-JC, K+2 ) EXTRA = ZERO TEMP = A( 1+( 1-ISKEW )*JC+IOFFG, JC ) ANGLE = TWOPI*DLARND( 1, ISEED ) C = COS( ANGLE ) S = -SIN( ANGLE ) CALL DLAROT( .FALSE., .TRUE., N-JC.GT.K, IL, C, S, $ A( ( 1-ISKEW )*JC+IOFFG, JC ), ILDA, $ TEMP, EXTRA ) ICOL = MAX( 1, JC-K+1 ) CALL DLAROT( .TRUE., .FALSE., .TRUE., JC+2-ICOL, C, $ S, A( JC-ISKEW*ICOL+IOFFG, ICOL ), $ ILDA, DUMMY, TEMP ) * * Chase EXTRA back down the matrix * ICOL = JC DO 220 JCH = JC + K, N - 1, K CALL DLARTG( A( JCH-ISKEW*ICOL+IOFFG, ICOL ), $ EXTRA, C, S, DUMMY ) TEMP = A( 1+( 1-ISKEW )*JCH+IOFFG, JCH ) CALL DLAROT( .TRUE., .TRUE., .TRUE., K+2, C, S, $ A( JCH-ISKEW*ICOL+IOFFG, ICOL ), $ ILDA, EXTRA, TEMP ) IL = MIN( N+1-JCH, K+2 ) EXTRA = ZERO CALL DLAROT( .FALSE., .TRUE., N-JCH.GT.K, IL, C, $ S, A( ( 1-ISKEW )*JCH+IOFFG, JCH ), $ ILDA, TEMP, EXTRA ) ICOL = JCH 220 CONTINUE 230 CONTINUE 240 CONTINUE * * If we need upper triangle, copy from lower. Note that * the order of copying is chosen to work for 'b' -> 'q' * IF( IPACK.NE.IPACKG .AND. IPACK.NE.4 ) THEN DO 260 JC = N, 1, -1 IROW = IOFFST - ISKEW*JC DO 250 JR = JC, MAX( 1, JC-UUB ), -1 A( JR+IROW, JC ) = A( JC-ISKEW*JR+IOFFG, JR ) 250 CONTINUE 260 CONTINUE IF( IPACK.EQ.6 ) THEN DO 280 JC = 1, UUB DO 270 JR = 1, UUB + 1 - JC A( JR, JC ) = ZERO 270 CONTINUE 280 CONTINUE END IF IF( IPACKG.EQ.5 ) THEN IPACKG = IPACK ELSE IPACKG = 0 END IF END IF END IF END IF * ELSE * * 4) Generate Banded Matrix by first * Rotating by random Unitary matrices, * then reducing the bandwidth using Householder * transformations. * * Note: we should get here only if LDA .ge. N * IF( ISYM.EQ.1 ) THEN * * Non-symmetric -- A = U D V * CALL DLAGGE( MR, NC, LLB, UUB, D, A, LDA, ISEED, WORK, $ IINFO ) ELSE * * Symmetric -- A = U D U' * CALL DLAGSY( M, LLB, D, A, LDA, ISEED, WORK, IINFO ) * END IF IF( IINFO.NE.0 ) THEN INFO = 3 RETURN END IF END IF * * 5) Pack the matrix * IF( IPACK.NE.IPACKG ) THEN IF( IPACK.EQ.1 ) THEN * * 'U' -- Upper triangular, not packed * DO 300 J = 1, M DO 290 I = J + 1, M A( I, J ) = ZERO 290 CONTINUE 300 CONTINUE * ELSE IF( IPACK.EQ.2 ) THEN * * 'L' -- Lower triangular, not packed * DO 320 J = 2, M DO 310 I = 1, J - 1 A( I, J ) = ZERO 310 CONTINUE 320 CONTINUE * ELSE IF( IPACK.EQ.3 ) THEN * * 'C' -- Upper triangle packed Columnwise. * ICOL = 1 IROW = 0 DO 340 J = 1, M DO 330 I = 1, J IROW = IROW + 1 IF( IROW.GT.LDA ) THEN IROW = 1 ICOL = ICOL + 1 END IF A( IROW, ICOL ) = A( I, J ) 330 CONTINUE 340 CONTINUE * ELSE IF( IPACK.EQ.4 ) THEN * * 'R' -- Lower triangle packed Columnwise. * ICOL = 1 IROW = 0 DO 360 J = 1, M DO 350 I = J, M IROW = IROW + 1 IF( IROW.GT.LDA ) THEN IROW = 1 ICOL = ICOL + 1 END IF A( IROW, ICOL ) = A( I, J ) 350 CONTINUE 360 CONTINUE * ELSE IF( IPACK.GE.5 ) THEN * * 'B' -- The lower triangle is packed as a band matrix. * 'Q' -- The upper triangle is packed as a band matrix. * 'Z' -- The whole matrix is packed as a band matrix. * IF( IPACK.EQ.5 ) $ UUB = 0 IF( IPACK.EQ.6 ) $ LLB = 0 * DO 380 J = 1, UUB DO 370 I = MIN( J+LLB, M ), 1, -1 A( I-J+UUB+1, J ) = A( I, J ) 370 CONTINUE 380 CONTINUE * DO 400 J = UUB + 2, N DO 390 I = J - UUB, MIN( J+LLB, M ) A( I-J+UUB+1, J ) = A( I, J ) 390 CONTINUE 400 CONTINUE END IF * * If packed, zero out extraneous elements. * * Symmetric/Triangular Packed -- * zero out everything after A(IROW,ICOL) * IF( IPACK.EQ.3 .OR. IPACK.EQ.4 ) THEN DO 420 JC = ICOL, M DO 410 JR = IROW + 1, LDA A( JR, JC ) = ZERO 410 CONTINUE IROW = 0 420 CONTINUE * ELSE IF( IPACK.GE.5 ) THEN * * Packed Band -- * 1st row is now in A( UUB+2-j, j), zero above it * m-th row is now in A( M+UUB-j,j), zero below it * last non-zero diagonal is now in A( UUB+LLB+1,j ), * zero below it, too. * IR1 = UUB + LLB + 2 IR2 = UUB + M + 2 DO 450 JC = 1, N DO 430 JR = 1, UUB + 1 - JC A( JR, JC ) = ZERO 430 CONTINUE DO 440 JR = MAX( 1, MIN( IR1, IR2-JC ) ), LDA A( JR, JC ) = ZERO 440 CONTINUE 450 CONTINUE END IF END IF * RETURN * * End of DLATMS * END SHAR_EOF fi # end of overwriting check if test -f 'slagge.f' then echo shar: will not over-write existing file "'slagge.f'" else cat << SHAR_EOF > 'slagge.f' SUBROUTINE SLAGGE( M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO ) * * -- LAPACK auxiliary test routine (version 2.0) * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDA, M, N * .. * .. Array Arguments .. INTEGER ISEED( 4 ) REAL A( LDA, * ), D( * ), WORK( * ) * .. * * Purpose * ======= * * SLAGGE generates a real general m by n matrix A, by pre- and post- * multiplying a real diagonal matrix D with random orthogonal matrices: * A = U*D*V. The lower and upper bandwidths may then be reduced to * kl and ku by additional orthogonal transformations. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * * KL (input) INTEGER * The number of nonzero subdiagonals within the band of A. * 0 <= KL <= M-1. * * KU (input) INTEGER * The number of nonzero superdiagonals within the band of A. * 0 <= KU <= N-1. * * D (input) REAL array, dimension (min(M,N)) * The diagonal elements of the diagonal matrix D. * * A (output) REAL array, dimension (LDA,N) * The generated m by n matrix A. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= M. * * ISEED (input/output) INTEGER array, dimension (4) * On entry, the seed of the random number generator; the array * elements must be between 0 and 4095, and ISEED(4) must be * odd. * On exit, the seed is updated. * * WORK (workspace) REAL array, dimension (M+N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. INTEGER I, J REAL TAU, WA, WB, WN * .. * .. External Subroutines .. EXTERNAL SGEMV, SGER, SLARNV, SSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN, SIGN * .. * .. External Functions .. REAL SNRM2 EXTERNAL SNRM2 * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( KL.LT.0 .OR. KL.GT.M-1 ) THEN INFO = -3 ELSE IF( KU.LT.0 .OR. KU.GT.N-1 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -7 END IF IF( INFO.LT.0 ) THEN CALL XERBLA( 'SLAGGE', -INFO ) RETURN END IF * * initialize A to diagonal matrix * DO 20 J = 1, N DO 10 I = 1, M A( I, J ) = ZERO 10 CONTINUE 20 CONTINUE DO 30 I = 1, MIN( M, N ) A( I, I ) = D( I ) 30 CONTINUE * * pre- and post-multiply A by random orthogonal matrices * DO 40 I = MIN( M, N ), 1, -1 IF( I.LT.M ) THEN * * generate random reflection * CALL SLARNV( 3, ISEED, M-I+1, WORK ) WN = SNRM2( M-I+1, WORK, 1 ) WA = SIGN( WN, WORK( 1 ) ) IF( WN.EQ.ZERO ) THEN TAU = ZERO ELSE WB = WORK( 1 ) + WA CALL SSCAL( M-I, ONE / WB, WORK( 2 ), 1 ) WORK( 1 ) = ONE TAU = WB / WA END IF * * multiply A(i:m,i:n) by random reflection from the left * CALL SGEMV( 'Transpose', M-I+1, N-I+1, ONE, A( I, I ), LDA, $ WORK, 1, ZERO, WORK( M+1 ), 1 ) CALL SGER( M-I+1, N-I+1, -TAU, WORK, 1, WORK( M+1 ), 1, $ A( I, I ), LDA ) END IF IF( I.LT.N ) THEN * * generate random reflection * CALL SLARNV( 3, ISEED, N-I+1, WORK ) WN = SNRM2( N-I+1, WORK, 1 ) WA = SIGN( WN, WORK( 1 ) ) IF( WN.EQ.ZERO ) THEN TAU = ZERO ELSE WB = WORK( 1 ) + WA CALL SSCAL( N-I, ONE / WB, WORK( 2 ), 1 ) WORK( 1 ) = ONE TAU = WB / WA END IF * * multiply A(i:m,i:n) by random reflection from the right * CALL SGEMV( 'No transpose', M-I+1, N-I+1, ONE, A( I, I ), $ LDA, WORK, 1, ZERO, WORK( N+1 ), 1 ) CALL SGER( M-I+1, N-I+1, -TAU, WORK( N+1 ), 1, WORK, 1, $ A( I, I ), LDA ) END IF 40 CONTINUE * * Reduce number of subdiagonals to KL and number of superdiagonals * to KU * DO 70 I = 1, MAX( M-1-KL, N-1-KU ) IF( KL.LE.KU ) THEN * * annihilate subdiagonal elements first (necessary if KL = 0) * IF( I.LE.MIN( M-1-KL, N ) ) THEN * * generate reflection to annihilate A(kl+i+1:m,i) * WN = SNRM2( M-KL-I+1, A( KL+I, I ), 1 ) WA = SIGN( WN, A( KL+I, I ) ) IF( WN.EQ.ZERO ) THEN TAU = ZERO ELSE WB = A( KL+I, I ) + WA CALL SSCAL( M-KL-I, ONE / WB, A( KL+I+1, I ), 1 ) A( KL+I, I ) = ONE TAU = WB / WA END IF * * apply reflection to A(kl+i:m,i+1:n) from the left * CALL SGEMV( 'Transpose', M-KL-I+1, N-I, ONE, $ A( KL+I, I+1 ), LDA, A( KL+I, I ), 1, ZERO, $ WORK, 1 ) CALL SGER( M-KL-I+1, N-I, -TAU, A( KL+I, I ), 1, WORK, 1, $ A( KL+I, I+1 ), LDA ) A( KL+I, I ) = -WA END IF * IF( I.LE.MIN( N-1-KU, M ) ) THEN * * generate reflection to annihilate A(i,ku+i+1:n) * WN = SNRM2( N-KU-I+1, A( I, KU+I ), LDA ) WA = SIGN( WN, A( I, KU+I ) ) IF( WN.EQ.ZERO ) THEN TAU = ZERO ELSE WB = A( I, KU+I ) + WA CALL SSCAL( N-KU-I, ONE / WB, A( I, KU+I+1 ), LDA ) A( I, KU+I ) = ONE TAU = WB / WA END IF * * apply reflection to A(i+1:m,ku+i:n) from the right * CALL SGEMV( 'No transpose', M-I, N-KU-I+1, ONE, $ A( I+1, KU+I ), LDA, A( I, KU+I ), LDA, ZERO, $ WORK, 1 ) CALL SGER( M-I, N-KU-I+1, -TAU, WORK, 1, A( I, KU+I ), $ LDA, A( I+1, KU+I ), LDA ) A( I, KU+I ) = -WA END IF ELSE * * annihilate superdiagonal elements first (necessary if * KU = 0) * IF( I.LE.MIN( N-1-KU, M ) ) THEN * * generate reflection to annihilate A(i,ku+i+1:n) * WN = SNRM2( N-KU-I+1, A( I, KU+I ), LDA ) WA = SIGN( WN, A( I, KU+I ) ) IF( WN.EQ.ZERO ) THEN TAU = ZERO ELSE WB = A( I, KU+I ) + WA CALL SSCAL( N-KU-I, ONE / WB, A( I, KU+I+1 ), LDA ) A( I, KU+I ) = ONE TAU = WB / WA END IF * * apply reflection to A(i+1:m,ku+i:n) from the right * CALL SGEMV( 'No transpose', M-I, N-KU-I+1, ONE, $ A( I+1, KU+I ), LDA, A( I, KU+I ), LDA, ZERO, $ WORK, 1 ) CALL SGER( M-I, N-KU-I+1, -TAU, WORK, 1, A( I, KU+I ), $ LDA, A( I+1, KU+I ), LDA ) A( I, KU+I ) = -WA END IF * IF( I.LE.MIN( M-1-KL, N ) ) THEN * * generate reflection to annihilate A(kl+i+1:m,i) * WN = SNRM2( M-KL-I+1, A( KL+I, I ), 1 ) WA = SIGN( WN, A( KL+I, I ) ) IF( WN.EQ.ZERO ) THEN TAU = ZERO ELSE WB = A( KL+I, I ) + WA CALL SSCAL( M-KL-I, ONE / WB, A( KL+I+1, I ), 1 ) A( KL+I, I ) = ONE TAU = WB / WA END IF * * apply reflection to A(kl+i:m,i+1:n) from the left * CALL SGEMV( 'Transpose', M-KL-I+1, N-I, ONE, $ A( KL+I, I+1 ), LDA, A( KL+I, I ), 1, ZERO, $ WORK, 1 ) CALL SGER( M-KL-I+1, N-I, -TAU, A( KL+I, I ), 1, WORK, 1, $ A( KL+I, I+1 ), LDA ) A( KL+I, I ) = -WA END IF END IF * DO 50 J = KL + I + 1, M A( J, I ) = ZERO 50 CONTINUE * DO 60 J = KU + I + 1, N A( I, J ) = ZERO 60 CONTINUE 70 CONTINUE RETURN * * End of SLAGGE * END SHAR_EOF fi # end of overwriting check if test -f 'slagsy.f' then echo shar: will not over-write existing file "'slagsy.f'" else cat << SHAR_EOF > 'slagsy.f' SUBROUTINE SLAGSY( N, K, D, A, LDA, ISEED, WORK, INFO ) * * -- LAPACK auxiliary test routine (version 2.0) * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, N * .. * .. Array Arguments .. INTEGER ISEED( 4 ) REAL A( LDA, * ), D( * ), WORK( * ) * .. * * Purpose * ======= * * SLAGSY generates a real symmetric matrix A, by pre- and post- * multiplying a real diagonal matrix D with a random orthogonal matrix: * A = U*D*U'. The semi-bandwidth may then be reduced to k by additional * orthogonal transformations. * * Arguments * ========= * * N (input) INTEGER * The order of the matrix A. N >= 0. * * K (input) INTEGER * The number of nonzero subdiagonals within the band of A. * 0 <= K <= N-1. * * D (input) REAL array, dimension (N) * The diagonal elements of the diagonal matrix D. * * A (output) REAL array, dimension (LDA,N) * The generated n by n symmetric matrix A (the full matrix is * stored). * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= N. * * ISEED (input/output) INTEGER array, dimension (4) * On entry, the seed of the random number generator; the array * elements must be between 0 and 4095, and ISEED(4) must be * odd. * On exit, the seed is updated. * * WORK (workspace) REAL array, dimension (2*N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE, HALF PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, HALF = 0.5E+0 ) * .. * .. Local Scalars .. INTEGER I, J REAL ALPHA, TAU, WA, WB, WN * .. * .. External Subroutines .. EXTERNAL SAXPY, SGEMV, SGER, SLARNV, SSCAL, SSYMV, $ SSYR2, XERBLA * .. * .. External Functions .. REAL SDOT, SNRM2 EXTERNAL SDOT, SNRM2 * .. * .. Intrinsic Functions .. INTRINSIC MAX, SIGN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 ELSE IF( K.LT.0 .OR. K.GT.N-1 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 END IF IF( INFO.LT.0 ) THEN CALL XERBLA( 'SLAGSY', -INFO ) RETURN END IF * * initialize lower triangle of A to diagonal matrix * DO 20 J = 1, N DO 10 I = J + 1, N A( I, J ) = ZERO 10 CONTINUE 20 CONTINUE DO 30 I = 1, N A( I, I ) = D( I ) 30 CONTINUE * * Generate lower triangle of symmetric matrix * DO 40 I = N - 1, 1, -1 * * generate random reflection * CALL SLARNV( 3, ISEED, N-I+1, WORK ) WN = SNRM2( N-I+1, WORK, 1 ) WA = SIGN( WN, WORK( 1 ) ) IF( WN.EQ.ZERO ) THEN TAU = ZERO ELSE WB = WORK( 1 ) + WA CALL SSCAL( N-I, ONE / WB, WORK( 2 ), 1 ) WORK( 1 ) = ONE TAU = WB / WA END IF * * apply random reflection to A(i:n,i:n) from the left * and the right * * compute y := tau * A * u * CALL SSYMV( 'Lower', N-I+1, TAU, A( I, I ), LDA, WORK, 1, ZERO, $ WORK( N+1 ), 1 ) * * compute v := y - 1/2 * tau * ( y, u ) * u * ALPHA = -HALF*TAU*SDOT( N-I+1, WORK( N+1 ), 1, WORK, 1 ) CALL SAXPY( N-I+1, ALPHA, WORK, 1, WORK( N+1 ), 1 ) * * apply the transformation as a rank-2 update to A(i:n,i:n) * CALL SSYR2( 'Lower', N-I+1, -ONE, WORK, 1, WORK( N+1 ), 1, $ A( I, I ), LDA ) 40 CONTINUE * * Reduce number of subdiagonals to K * DO 60 I = 1, N - 1 - K * * generate reflection to annihilate A(k+i+1:n,i) * WN = SNRM2( N-K-I+1, A( K+I, I ), 1 ) WA = SIGN( WN, A( K+I, I ) ) IF( WN.EQ.ZERO ) THEN TAU = ZERO ELSE WB = A( K+I, I ) + WA CALL SSCAL( N-K-I, ONE / WB, A( K+I+1, I ), 1 ) A( K+I, I ) = ONE TAU = WB / WA END IF * * apply reflection to A(k+i:n,i+1:k+i-1) from the left * CALL SGEMV( 'Transpose', N-K-I+1, K-1, ONE, A( K+I, I+1 ), LDA, $ A( K+I, I ), 1, ZERO, WORK, 1 ) CALL SGER( N-K-I+1, K-1, -TAU, A( K+I, I ), 1, WORK, 1, $ A( K+I, I+1 ), LDA ) * * apply reflection to A(k+i:n,k+i:n) from the left and the right * * compute y := tau * A * u * CALL SSYMV( 'Lower', N-K-I+1, TAU, A( K+I, K+I ), LDA, $ A( K+I, I ), 1, ZERO, WORK, 1 ) * * compute v := y - 1/2 * tau * ( y, u ) * u * ALPHA = -HALF*TAU*SDOT( N-K-I+1, WORK, 1, A( K+I, I ), 1 ) CALL SAXPY( N-K-I+1, ALPHA, A( K+I, I ), 1, WORK, 1 ) * * apply symmetric rank-2 update to A(k+i:n,k+i:n) * CALL SSYR2( 'Lower', N-K-I+1, -ONE, A( K+I, I ), 1, WORK, 1, $ A( K+I, K+I ), LDA ) * A( K+I, I ) = -WA DO 50 J = K + I + 1, N A( J, I ) = ZERO 50 CONTINUE 60 CONTINUE * * Store full symmetric matrix * DO 80 J = 1, N DO 70 I = J + 1, N A( J, I ) = A( I, J ) 70 CONTINUE 80 CONTINUE RETURN * * End of SLAGSY * END SHAR_EOF fi # end of overwriting check if test -f 'slaran.f' then echo shar: will not over-write existing file "'slaran.f'" else cat << SHAR_EOF > 'slaran.f' REAL FUNCTION SLARAN( ISEED ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Array Arguments .. INTEGER ISEED( 4 ) * .. * * Purpose * ======= * * SLARAN returns a random real number from a uniform (0,1) * distribution. * * Arguments * ========= * * ISEED (input/output) INTEGER array, dimension (4) * On entry, the seed of the random number generator; the array * elements must be between 0 and 4095, and ISEED(4) must be * odd. * On exit, the seed is updated. * * Further Details * =============== * * This routine uses a multiplicative congruential method with modulus * 2**48 and multiplier 33952834046453 (see G.S.Fishman, * 'Multiplicative congruential random number generators with modulus * 2**b: an exhaustive analysis for b = 32 and a partial analysis for * b = 48', Math. Comp. 189, pp 331-344, 1990). * * 48-bit integers are stored in 4 integer array elements with 12 bits * per element. Hence the routine is portable across machines with * integers of 32 bits or more. * * ===================================================================== * * .. Parameters .. INTEGER M1, M2, M3, M4 PARAMETER ( M1 = 494, M2 = 322, M3 = 2508, M4 = 2549 ) REAL ONE PARAMETER ( ONE = 1.0E+0 ) INTEGER IPW2 REAL R PARAMETER ( IPW2 = 4096, R = ONE / IPW2 ) * .. * .. Local Scalars .. INTEGER IT1, IT2, IT3, IT4 * .. * .. Intrinsic Functions .. INTRINSIC MOD, REAL * .. * .. Executable Statements .. * * multiply the seed by the multiplier modulo 2**48 * IT4 = ISEED( 4 )*M4 IT3 = IT4 / IPW2 IT4 = IT4 - IPW2*IT3 IT3 = IT3 + ISEED( 3 )*M4 + ISEED( 4 )*M3 IT2 = IT3 / IPW2 IT3 = IT3 - IPW2*IT2 IT2 = IT2 + ISEED( 2 )*M4 + ISEED( 3 )*M3 + ISEED( 4 )*M2 IT1 = IT2 / IPW2 IT2 = IT2 - IPW2*IT1 IT1 = IT1 + ISEED( 1 )*M4 + ISEED( 2 )*M3 + ISEED( 3 )*M2 + $ ISEED( 4 )*M1 IT1 = MOD( IT1, IPW2 ) * * return updated seed * ISEED( 1 ) = IT1 ISEED( 2 ) = IT2 ISEED( 3 ) = IT3 ISEED( 4 ) = IT4 * * convert 48-bit integer to a real number in the interval (0,1) * SLARAN = R*( REAL( IT1 )+R*( REAL( IT2 )+R*( REAL( IT3 )+R* $ ( REAL( IT4 ) ) ) ) ) RETURN * * End of SLARAN * END SHAR_EOF fi # end of overwriting check if test -f 'slarge.f' then echo shar: will not over-write existing file "'slarge.f'" else cat << SHAR_EOF > 'slarge.f' SUBROUTINE SLARGE( N, A, LDA, ISEED, WORK, INFO ) * * -- LAPACK auxiliary test routine (version 2.0) * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. INTEGER INFO, LDA, N * .. * .. Array Arguments .. INTEGER ISEED( 4 ) REAL A( LDA, * ), WORK( * ) * .. * * Purpose * ======= * * SLARGE pre- and post-multiplies a real general n by n matrix A * with a random orthogonal matrix: A = U*D*U'. * * Arguments * ========= * * N (input) INTEGER * The order of the matrix A. N >= 0. * * A (input/output) REAL array, dimension (LDA,N) * On entry, the original n by n matrix A. * On exit, A is overwritten by U*A*U' for some random * orthogonal matrix U. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= N. * * ISEED (input/output) INTEGER array, dimension (4) * On entry, the seed of the random number generator; the array * elements must be between 0 and 4095, and ISEED(4) must be * odd. * On exit, the seed is updated. * * WORK (workspace) REAL array, dimension (2*N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. INTEGER I REAL TAU, WA, WB, WN * .. * .. External Subroutines .. EXTERNAL SGEMV, SGER, SLARNV, SSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, SIGN * .. * .. External Functions .. REAL SNRM2 EXTERNAL SNRM2 * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -3 END IF IF( INFO.LT.0 ) THEN CALL XERBLA( 'SLARGE', -INFO ) RETURN END IF * * pre- and post-multiply A by random orthogonal matrix * DO 10 I = N, 1, -1 * * generate random reflection * CALL SLARNV( 3, ISEED, N-I+1, WORK ) WN = SNRM2( N-I+1, WORK, 1 ) WA = SIGN( WN, WORK( 1 ) ) IF( WN.EQ.ZERO ) THEN TAU = ZERO ELSE WB = WORK( 1 ) + WA CALL SSCAL( N-I, ONE / WB, WORK( 2 ), 1 ) WORK( 1 ) = ONE TAU = WB / WA END IF * * multiply A(i:n,1:n) by random reflection from the left * CALL SGEMV( 'Transpose', N-I+1, N, ONE, A( I, 1 ), LDA, WORK, $ 1, ZERO, WORK( N+1 ), 1 ) CALL SGER( N-I+1, N, -TAU, WORK, 1, WORK( N+1 ), 1, A( I, 1 ), $ LDA ) * * multiply A(1:n,i:n) by random reflection from the right * CALL SGEMV( 'No transpose', N, N-I+1, ONE, A( 1, I ), LDA, $ WORK, 1, ZERO, WORK( N+1 ), 1 ) CALL SGER( N, N-I+1, -TAU, WORK( N+1 ), 1, WORK, 1, A( 1, I ), $ LDA ) 10 CONTINUE RETURN * * End of SLARGE * END SHAR_EOF fi # end of overwriting check if test -f 'slarnd.f' then echo shar: will not over-write existing file "'slarnd.f'" else cat << SHAR_EOF > 'slarnd.f' REAL FUNCTION SLARND( IDIST, ISEED ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. INTEGER IDIST * .. * .. Array Arguments .. INTEGER ISEED( 4 ) * .. * * Purpose * ======= * * SLARND returns a random real number from a uniform or normal * distribution. * * Arguments * ========= * * IDIST (input) INTEGER * Specifies the distribution of the random numbers: * = 1: uniform (0,1) * = 2: uniform (-1,1) * = 3: normal (0,1) * * ISEED (input/output) INTEGER array, dimension (4) * On entry, the seed of the random number generator; the array * elements must be between 0 and 4095, and ISEED(4) must be * odd. * On exit, the seed is updated. * * Further Details * =============== * * This routine calls the auxiliary routine SLARAN to generate a random * real number from a uniform (0,1) distribution. The Box-Muller method * is used to transform numbers from a uniform to a normal distribution. * * ===================================================================== * * .. Parameters .. REAL ONE, TWO PARAMETER ( ONE = 1.0E+0, TWO = 2.0E+0 ) REAL TWOPI PARAMETER ( TWOPI = 6.2831853071795864769252867663E+0 ) * .. * .. Local Scalars .. REAL T1, T2 * .. * .. External Functions .. REAL SLARAN EXTERNAL SLARAN * .. * .. Intrinsic Functions .. INTRINSIC COS, LOG, SQRT * .. * .. Executable Statements .. * * Generate a real random number from a uniform (0,1) distribution * T1 = SLARAN( ISEED ) * IF( IDIST.EQ.1 ) THEN * * uniform (0,1) * SLARND = T1 ELSE IF( IDIST.EQ.2 ) THEN * * uniform (-1,1) * SLARND = TWO*T1 - ONE ELSE IF( IDIST.EQ.3 ) THEN * * normal (0,1) * T2 = SLARAN( ISEED ) SLARND = SQRT( -TWO*LOG( T1 ) )*COS( TWOPI*T2 ) END IF RETURN * * End of SLARND * END SHAR_EOF fi # end of overwriting check if test -f 'slaror.f' then echo shar: will not over-write existing file "'slaror.f'" else cat << SHAR_EOF > 'slaror.f' SUBROUTINE SLAROR( SIDE, INIT, M, N, A, LDA, ISEED, X, INFO ) * * -- LAPACK auxiliary test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER INIT, SIDE INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. INTEGER ISEED( 4 ) REAL A( LDA, * ), X( * ) * .. * * Purpose * ======= * * SLAROR pre- or post-multiplies an M by N matrix A by a random * orthogonal matrix U, overwriting A. A may optionally be initialized * to the identity matrix before multiplying by U. U is generated using * the method of G.W. Stewart (SIAM J. Numer. Anal. 17, 1980, 403-409). * * Arguments * ========= * * SIDE (input) CHARACTER*1 * Specifies whether A is multiplied on the left or right by U. * = 'L': Multiply A on the left (premultiply) by U * = 'R': Multiply A on the right (postmultiply) by U' * = 'C' or 'T': Multiply A on the left by U and the right * by U' (Here, U' means U-transpose.) * * INIT (input) CHARACTER*1 * Specifies whether or not A should be initialized to the * identity matrix. * = 'I': Initialize A to (a section of) the identity matrix * before applying U. * = 'N': No initialization. Apply U to the input matrix A. * * INIT = 'I' may be used to generate square or rectangular * orthogonal matrices: * * For M = N and SIDE = 'L' or 'R', the rows will be orthogonal * to each other, as will the columns. * * If M < N, SIDE = 'R' produces a dense matrix whose rows are * orthogonal and whose columns are not, while SIDE = 'L' * produces a matrix whose rows are orthogonal, and whose first * M columns are orthogonal, and whose remaining columns are * zero. * * If M > N, SIDE = 'L' produces a dense matrix whose columns * are orthogonal and whose rows are not, while SIDE = 'R' * produces a matrix whose columns are orthogonal, and whose * first M rows are orthogonal, and whose remaining rows are * zero. * * M (input) INTEGER * The number of rows of A. * * N (input) INTEGER * The number of columns of A. * * A (input/output) REAL array, dimension (LDA, N) * On entry, the array A. * On exit, overwritten by U A ( if SIDE = 'L' ), * or by A U ( if SIDE = 'R' ), * or by U A U' ( if SIDE = 'C' or 'T'). * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * ISEED (input/output) INTEGER array, dimension (4) * On entry ISEED specifies the seed of the random number * generator. The array elements should be between 0 and 4095; * if not they will be reduced mod 4096. Also, ISEED(4) must * be odd. The random number generator uses a linear * congruential sequence limited to small integers, and so * should produce machine independent random numbers. The * values of ISEED are changed on exit, and can be used in the * next call to SLAROR to continue the same random number * sequence. * * X (workspace) REAL array, dimension (3*MAX( M, N )) * Workspace of length * 2*M + N if SIDE = 'L', * 2*N + M if SIDE = 'R', * 3*N if SIDE = 'C' or 'T'. * * INFO (output) INTEGER * An error flag. It is set to: * = 0: normal return * < 0: if INFO = -k, the k-th argument had an illegal value * = 1: if the random numbers generated by SLARND are bad. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE, TOOSML PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, $ TOOSML = 1.0E-20 ) * .. * .. Local Scalars .. INTEGER IROW, ITYPE, IXFRM, J, JCOL, KBEG, NXFRM REAL FACTOR, XNORM, XNORMS * .. * .. External Functions .. LOGICAL LSAME REAL SLARND, SNRM2 EXTERNAL LSAME, SLARND, SNRM2 * .. * .. External Subroutines .. EXTERNAL SGEMV, SGER, SLASET, SSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, SIGN * .. * .. Executable Statements .. * IF( N.EQ.0 .OR. M.EQ.0 ) $ RETURN * ITYPE = 0 IF( LSAME( SIDE, 'L' ) ) THEN ITYPE = 1 ELSE IF( LSAME( SIDE, 'R' ) ) THEN ITYPE = 2 ELSE IF( LSAME( SIDE, 'C' ) .OR. LSAME( SIDE, 'T' ) ) THEN ITYPE = 3 END IF * * Check for argument errors. * INFO = 0 IF( ITYPE.EQ.0 ) THEN INFO = -1 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.3 .AND. N.NE.M ) ) THEN INFO = -4 ELSE IF( LDA.LT.M ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SLAROR', -INFO ) RETURN END IF * IF( ITYPE.EQ.1 ) THEN NXFRM = M ELSE NXFRM = N END IF * * Initialize A to the identity matrix if desired * IF( LSAME( INIT, 'I' ) ) $ CALL SLASET( 'Full', M, N, ZERO, ONE, A, LDA ) * * If no rotation possible, multiply by random +/-1 * * Compute rotation by computing Householder transformations * H(2), H(3), ..., H(nhouse) * DO 10 J = 1, NXFRM X( J ) = ZERO 10 CONTINUE * DO 30 IXFRM = 2, NXFRM KBEG = NXFRM - IXFRM + 1 * * Generate independent normal( 0, 1 ) random numbers * DO 20 J = KBEG, NXFRM X( J ) = SLARND( 3, ISEED ) 20 CONTINUE * * Generate a Householder transformation from the random vector X * XNORM = SNRM2( IXFRM, X( KBEG ), 1 ) XNORMS = SIGN( XNORM, X( KBEG ) ) X( KBEG+NXFRM ) = SIGN( ONE, -X( KBEG ) ) FACTOR = XNORMS*( XNORMS+X( KBEG ) ) IF( ABS( FACTOR ).LT.TOOSML ) THEN INFO = 1 CALL XERBLA( 'SLAROR', INFO ) RETURN ELSE FACTOR = ONE / FACTOR END IF X( KBEG ) = X( KBEG ) + XNORMS * * Apply Householder transformation to A * IF( ITYPE.EQ.1 .OR. ITYPE.EQ.3 ) THEN * * Apply H(k) from the left. * CALL SGEMV( 'T', IXFRM, N, ONE, A( KBEG, 1 ), LDA, $ X( KBEG ), 1, ZERO, X( 2*NXFRM+1 ), 1 ) CALL SGER( IXFRM, N, -FACTOR, X( KBEG ), 1, X( 2*NXFRM+1 ), $ 1, A( KBEG, 1 ), LDA ) * END IF * IF( ITYPE.EQ.2 .OR. ITYPE.EQ.3 ) THEN * * Apply H(k) from the right. * CALL SGEMV( 'N', M, IXFRM, ONE, A( 1, KBEG ), LDA, $ X( KBEG ), 1, ZERO, X( 2*NXFRM+1 ), 1 ) CALL SGER( M, IXFRM, -FACTOR, X( 2*NXFRM+1 ), 1, X( KBEG ), $ 1, A( 1, KBEG ), LDA ) * END IF 30 CONTINUE * X( 2*NXFRM ) = SIGN( ONE, SLARND( 3, ISEED ) ) * * Scale the matrix A by D. * IF( ITYPE.EQ.1 .OR. ITYPE.EQ.3 ) THEN DO 40 IROW = 1, M CALL SSCAL( N, X( NXFRM+IROW ), A( IROW, 1 ), LDA ) 40 CONTINUE END IF * IF( ITYPE.EQ.2 .OR. ITYPE.EQ.3 ) THEN DO 50 JCOL = 1, N CALL SSCAL( M, X( NXFRM+JCOL ), A( 1, JCOL ), 1 ) 50 CONTINUE END IF RETURN * * End of SLAROR * END SHAR_EOF fi # end of overwriting check if test -f 'slarot.f' then echo shar: will not over-write existing file "'slarot.f'" else cat << SHAR_EOF > 'slarot.f' SUBROUTINE SLAROT( LROWS, LLEFT, LRIGHT, NL, C, S, A, LDA, XLEFT, $ XRIGHT ) * * -- LAPACK auxiliary test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. LOGICAL LLEFT, LRIGHT, LROWS INTEGER LDA, NL REAL C, S, XLEFT, XRIGHT * .. * .. Array Arguments .. REAL A( * ) * .. * * Purpose * ======= * * SLAROT applies a (Givens) rotation to two adjacent rows or * columns, where one element of the first and/or last column/row * may be a separate variable. This is specifically indended * for use on matrices stored in some format other than GE, so * that elements of the matrix may be used or modified for which * no array element is provided. * * One example is a symmetric matrix in SB format (bandwidth=4), for * which UPLO='L': Two adjacent rows will have the format: * * row j: * * * * * . . . . * row j+1: * * * * * . . . . * * '*' indicates elements for which storage is provided, * '.' indicates elements for which no storage is provided, but * are not necessarily zero; their values are determined by * symmetry. ' ' indicates elements which are necessarily zero, * and have no storage provided. * * Those columns which have two '*'s can be handled by SROT. * Those columns which have no '*'s can be ignored, since as long * as the Givens rotations are carefully applied to preserve * symmetry, their values are determined. * Those columns which have one '*' have to be handled separately, * by using separate variables "p" and "q": * * row j: * * * * * p . . . * row j+1: q * * * * * . . . . * * The element p would have to be set correctly, then that column * is rotated, setting p to its new value. The next call to * SLAROT would rotate columns j and j+1, using p, and restore * symmetry. The element q would start out being zero, and be * made non-zero by the rotation. Later, rotations would presumably * be chosen to zero q out. * * Typical Calling Sequences: rotating the i-th and (i+1)-st rows. * ------- ------- --------- * * General dense matrix: * * CALL SLAROT(.TRUE.,.FALSE.,.FALSE., N, C,S, * A(i,1),LDA, DUMMY, DUMMY) * * General banded matrix in GB format: * * j = MAX(1, i-KL ) * NL = MIN( N, i+KU+1 ) + 1-j * CALL SLAROT( .TRUE., i-KL.GE.1, i+KU.LT.N, NL, C,S, * A(KU+i+1-j,j),LDA-1, XLEFT, XRIGHT ) * * [ note that i+1-j is just MIN(i,KL+1) ] * * Symmetric banded matrix in SY format, bandwidth K, * lower triangle only: * * j = MAX(1, i-K ) * NL = MIN( K+1, i ) + 1 * CALL SLAROT( .TRUE., i-K.GE.1, .TRUE., NL, C,S, * A(i,j), LDA, XLEFT, XRIGHT ) * * Same, but upper triangle only: * * NL = MIN( K+1, N-i ) + 1 * CALL SLAROT( .TRUE., .TRUE., i+K.LT.N, NL, C,S, * A(i,i), LDA, XLEFT, XRIGHT ) * * Symmetric banded matrix in SB format, bandwidth K, * lower triangle only: * * [ same as for SY, except:] * . . . . * A(i+1-j,j), LDA-1, XLEFT, XRIGHT ) * * [ note that i+1-j is just MIN(i,K+1) ] * * Same, but upper triangle only: * . . . * A(K+1,i), LDA-1, XLEFT, XRIGHT ) * * Rotating columns is just the transpose of rotating rows, except * for GB and SB: (rotating columns i and i+1) * * GB: * j = MAX(1, i-KU ) * NL = MIN( N, i+KL+1 ) + 1-j * CALL SLAROT( .TRUE., i-KU.GE.1, i+KL.LT.N, NL, C,S, * A(KU+j+1-i,i),LDA-1, XTOP, XBOTTM ) * * [note that KU+j+1-i is just MAX(1,KU+2-i)] * * SB: (upper triangle) * * . . . . . . * A(K+j+1-i,i),LDA-1, XTOP, XBOTTM ) * * SB: (lower triangle) * * . . . . . . * A(1,i),LDA-1, XTOP, XBOTTM ) * * Arguments * ========= * * LROWS - LOGICAL * If .TRUE., then SLAROT will rotate two rows. If .FALSE., * then it will rotate two columns. * Not modified. * * LLEFT - LOGICAL * If .TRUE., then XLEFT will be used instead of the * corresponding element of A for the first element in the * second row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) * If .FALSE., then the corresponding element of A will be * used. * Not modified. * * LRIGHT - LOGICAL * If .TRUE., then XRIGHT will be used instead of the * corresponding element of A for the last element in the * first row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) If * .FALSE., then the corresponding element of A will be used. * Not modified. * * NL - INTEGER * The length of the rows (if LROWS=.TRUE.) or columns (if * LROWS=.FALSE.) to be rotated. If XLEFT and/or XRIGHT are * used, the columns/rows they are in should be included in * NL, e.g., if LLEFT = LRIGHT = .TRUE., then NL must be at * least 2. The number of rows/columns to be rotated * exclusive of those involving XLEFT and/or XRIGHT may * not be negative, i.e., NL minus how many of LLEFT and * LRIGHT are .TRUE. must be at least zero; if not, XERBLA * will be called. * Not modified. * * C, S - REAL * Specify the Givens rotation to be applied. If LROWS is * true, then the matrix ( c s ) * (-s c ) is applied from the left; * if false, then the transpose thereof is applied from the * right. For a Givens rotation, C**2 + S**2 should be 1, * but this is not checked. * Not modified. * * A - REAL array. * The array containing the rows/columns to be rotated. The * first element of A should be the upper left element to * be rotated. * Read and modified. * * LDA - INTEGER * The "effective" leading dimension of A. If A contains * a matrix stored in GE or SY format, then this is just * the leading dimension of A as dimensioned in the calling * routine. If A contains a matrix stored in band (GB or SB) * format, then this should be *one less* than the leading * dimension used in the calling routine. Thus, if * A were dimensioned A(LDA,*) in SLAROT, then A(1,j) would * be the j-th element in the first of the two rows * to be rotated, and A(2,j) would be the j-th in the second, * regardless of how the array may be stored in the calling * routine. [A cannot, however, actually be dimensioned thus, * since for band format, the row number may exceed LDA, which * is not legal FORTRAN.] * If LROWS=.TRUE., then LDA must be at least 1, otherwise * it must be at least NL minus the number of .TRUE. values * in XLEFT and XRIGHT. * Not modified. * * XLEFT - REAL * If LLEFT is .TRUE., then XLEFT will be used and modified * instead of A(2,1) (if LROWS=.TRUE.) or A(1,2) * (if LROWS=.FALSE.). * Read and modified. * * XRIGHT - REAL * If LRIGHT is .TRUE., then XRIGHT will be used and modified * instead of A(1,NL) (if LROWS=.TRUE.) or A(NL,1) * (if LROWS=.FALSE.). * Read and modified. * * ===================================================================== * * .. Local Scalars .. INTEGER IINC, INEXT, IX, IY, IYT, NT * .. * .. Local Arrays .. REAL XT( 2 ), YT( 2 ) * .. * .. External Subroutines .. EXTERNAL SROT, XERBLA * .. * .. Executable Statements .. * * Set up indices, arrays for ends * IF( LROWS ) THEN IINC = LDA INEXT = 1 ELSE IINC = 1 INEXT = LDA END IF * IF( LLEFT ) THEN NT = 1 IX = 1 + IINC IY = 2 + LDA XT( 1 ) = A( 1 ) YT( 1 ) = XLEFT ELSE NT = 0 IX = 1 IY = 1 + INEXT END IF * IF( LRIGHT ) THEN IYT = 1 + INEXT + ( NL-1 )*IINC NT = NT + 1 XT( NT ) = XRIGHT YT( NT ) = A( IYT ) END IF * * Check for errors * IF( NL.LT.NT ) THEN CALL XERBLA( 'SLAROT', 4 ) RETURN END IF IF( LDA.LE.0 .OR. ( .NOT.LROWS .AND. LDA.LT.NL-NT ) ) THEN CALL XERBLA( 'SLAROT', 8 ) RETURN END IF * * Rotate * CALL SROT( NL-NT, A( IX ), IINC, A( IY ), IINC, C, S ) CALL SROT( NT, XT, 1, YT, 1, C, S ) * * Stuff values back into XLEFT, XRIGHT, etc. * IF( LLEFT ) THEN A( 1 ) = XT( 1 ) XLEFT = YT( 1 ) END IF * IF( LRIGHT ) THEN XRIGHT = XT( NT ) A( IYT ) = YT( NT ) END IF * RETURN * * End of SLAROT * END SHAR_EOF fi # end of overwriting check if test -f 'slatm1.f' then echo shar: will not over-write existing file "'slatm1.f'" else cat << SHAR_EOF > 'slatm1.f' SUBROUTINE SLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO ) * * -- LAPACK auxiliary test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. INTEGER IDIST, INFO, IRSIGN, MODE, N REAL COND * .. * .. Array Arguments .. INTEGER ISEED( 4 ) REAL D( * ) * .. * * Purpose * ======= * * SLATM1 computes the entries of D(1..N) as specified by * MODE, COND and IRSIGN. IDIST and ISEED determine the generation * of random numbers. SLATM1 is called by SLATMR to generate * random test matrices for LAPACK programs. * * Arguments * ========= * * MODE - INTEGER * On entry describes how D is to be computed: * MODE = 0 means do not change D. * MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND * MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND * MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) * MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) * MODE = 5 sets D to random numbers in the range * ( 1/COND , 1 ) such that their logarithms * are uniformly distributed. * MODE = 6 set D to random numbers from same distribution * as the rest of the matrix. * MODE < 0 has the same meaning as ABS(MODE), except that * the order of the elements of D is reversed. * Thus if MODE is positive, D has entries ranging from * 1 to 1/COND, if negative, from 1/COND to 1, * Not modified. * * COND - REAL * On entry, used as described under MODE above. * If used, it must be >= 1. Not modified. * * IRSIGN - INTEGER * On entry, if MODE neither -6, 0 nor 6, determines sign of * entries of D * 0 => leave entries of D unchanged * 1 => multiply each entry of D by 1 or -1 with probability .5 * * IDIST - CHARACTER*1 * On entry, IDIST specifies the type of distribution to be * used to generate a random matrix . * 1 => UNIFORM( 0, 1 ) * 2 => UNIFORM( -1, 1 ) * 3 => NORMAL( 0, 1 ) * Not modified. * * ISEED - INTEGER array, dimension ( 4 ) * On entry ISEED specifies the seed of the random number * generator. The random number generator uses a * linear congruential sequence limited to small * integers, and so should produce machine independent * random numbers. The values of ISEED are changed on * exit, and can be used in the next call to SLATM1 * to continue the same random number sequence. * Changed on exit. * * D - REAL array, dimension ( MIN( M , N ) ) * Array to be computed according to MODE, COND and IRSIGN. * May be changed on exit if MODE is nonzero. * * N - INTEGER * Number of entries of D. Not modified. * * INFO - INTEGER * 0 => normal termination * -1 => if MODE not in range -6 to 6 * -2 => if MODE neither -6, 0 nor 6, and * IRSIGN neither 0 nor 1 * -3 => if MODE neither -6, 0 nor 6 and COND less than 1 * -4 => if MODE equals 6 or -6 and IDIST not in range 1 to 3 * -7 => if N negative * * ===================================================================== * * .. Parameters .. REAL ONE PARAMETER ( ONE = 1.0E0 ) REAL HALF PARAMETER ( HALF = 0.5E0 ) * .. * .. Local Scalars .. INTEGER I REAL ALPHA, TEMP * .. * .. External Functions .. REAL SLARAN EXTERNAL SLARAN * .. * .. External Subroutines .. EXTERNAL SLARNV, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, EXP, LOG, REAL * .. * .. Executable Statements .. * * Decode and Test the input parameters. Initialize flags & seed. * INFO = 0 * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Set INFO if an error * IF( MODE.LT.-6 .OR. MODE.GT.6 ) THEN INFO = -1 ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND. $ ( IRSIGN.NE.0 .AND. IRSIGN.NE.1 ) ) THEN INFO = -2 ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND. $ COND.LT.ONE ) THEN INFO = -3 ELSE IF( ( MODE.EQ.6 .OR. MODE.EQ.-6 ) .AND. $ ( IDIST.LT.1 .OR. IDIST.GT.3 ) ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -7 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'SLATM1', -INFO ) RETURN END IF * * Compute D according to COND and MODE * IF( MODE.NE.0 ) THEN GO TO ( 10, 30, 50, 70, 90, 110 )ABS( MODE ) * * One large D value: * 10 CONTINUE DO 20 I = 1, N D( I ) = ONE / COND 20 CONTINUE D( 1 ) = ONE GO TO 120 * * One small D value: * 30 CONTINUE DO 40 I = 1, N D( I ) = ONE 40 CONTINUE D( N ) = ONE / COND GO TO 120 * * Exponentially distributed D values: * 50 CONTINUE D( 1 ) = ONE IF( N.GT.1 ) THEN ALPHA = COND**( -ONE / REAL( N-1 ) ) DO 60 I = 2, N D( I ) = ALPHA**( I-1 ) 60 CONTINUE END IF GO TO 120 * * Arithmetically distributed D values: * 70 CONTINUE D( 1 ) = ONE IF( N.GT.1 ) THEN TEMP = ONE / COND ALPHA = ( ONE-TEMP ) / REAL( N-1 ) DO 80 I = 2, N D( I ) = REAL( N-I )*ALPHA + TEMP 80 CONTINUE END IF GO TO 120 * * Randomly distributed D values on ( 1/COND , 1): * 90 CONTINUE ALPHA = LOG( ONE / COND ) DO 100 I = 1, N D( I ) = EXP( ALPHA*SLARAN( ISEED ) ) 100 CONTINUE GO TO 120 * * Randomly distributed D values from IDIST * 110 CONTINUE CALL SLARNV( IDIST, ISEED, N, D ) * 120 CONTINUE * * If MODE neither -6 nor 0 nor 6, and IRSIGN = 1, assign * random signs to D * IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND. $ IRSIGN.EQ.1 ) THEN DO 130 I = 1, N TEMP = SLARAN( ISEED ) IF( TEMP.GT.HALF ) $ D( I ) = -D( I ) 130 CONTINUE END IF * * Reverse if MODE < 0 * IF( MODE.LT.0 ) THEN DO 140 I = 1, N / 2 TEMP = D( I ) D( I ) = D( N+1-I ) D( N+1-I ) = TEMP 140 CONTINUE END IF * END IF * RETURN * * End of SLATM1 * END SHAR_EOF fi # end of overwriting check if test -f 'slatm2.f' then echo shar: will not over-write existing file "'slatm2.f'" else cat << SHAR_EOF > 'slatm2.f' REAL FUNCTION SLATM2( M, N, I, J, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE ) * * -- LAPACK auxiliary test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. * INTEGER I, IDIST, IGRADE, IPVTNG, J, KL, KU, M, N REAL SPARSE * .. * * .. Array Arguments .. * INTEGER ISEED( 4 ), IWORK( * ) REAL D( * ), DL( * ), DR( * ) * .. * * Purpose * ======= * * SLATM2 returns the (I,J) entry of a random matrix of dimension * (M, N) described by the other paramters. It is called by the * SLATMR routine in order to build random test matrices. No error * checking on parameters is done, because this routine is called in * a tight loop by SLATMR which has already checked the parameters. * * Use of SLATM2 differs from SLATM3 in the order in which the random * number generator is called to fill in random matrix entries. * With SLATM2, the generator is called to fill in the pivoted matrix * columnwise. With SLATM3, the generator is called to fill in the * matrix columnwise, after which it is pivoted. Thus, SLATM3 can * be used to construct random matrices which differ only in their * order of rows and/or columns. SLATM2 is used to construct band * matrices while avoiding calling the random number generator for * entries outside the band (and therefore generating random numbers * * The matrix whose (I,J) entry is returned is constructed as * follows (this routine only computes one entry): * * If I is outside (1..M) or J is outside (1..N), return zero * (this is convenient for generating matrices in band format). * * Generate a matrix A with random entries of distribution IDIST. * * Set the diagonal to D. * * Grade the matrix, if desired, from the left (by DL) and/or * from the right (by DR or DL) as specified by IGRADE. * * Permute, if desired, the rows and/or columns as specified by * IPVTNG and IWORK. * * Band the matrix to have lower bandwidth KL and upper * bandwidth KU. * * Set random entries to zero as specified by SPARSE. * * Arguments * ========= * * M - INTEGER * Number of rows of matrix. Not modified. * * N - INTEGER * Number of columns of matrix. Not modified. * * I - INTEGER * Row of entry to be returned. Not modified. * * J - INTEGER * Column of entry to be returned. Not modified. * * KL - INTEGER * Lower bandwidth. Not modified. * * KU - INTEGER * Upper bandwidth. Not modified. * * IDIST - INTEGER * On entry, IDIST specifies the type of distribution to be * used to generate a random matrix . * 1 => UNIFORM( 0, 1 ) * 2 => UNIFORM( -1, 1 ) * 3 => NORMAL( 0, 1 ) * Not modified. * * ISEED - INTEGER array of dimension ( 4 ) * Seed for random number generator. * Changed on exit. * * D - REAL array of dimension ( MIN( I , J ) ) * Diagonal entries of matrix. Not modified. * * IGRADE - INTEGER * Specifies grading of matrix as follows: * 0 => no grading * 1 => matrix premultiplied by diag( DL ) * 2 => matrix postmultiplied by diag( DR ) * 3 => matrix premultiplied by diag( DL ) and * postmultiplied by diag( DR ) * 4 => matrix premultiplied by diag( DL ) and * postmultiplied by inv( diag( DL ) ) * 5 => matrix premultiplied by diag( DL ) and * postmultiplied by diag( DL ) * Not modified. * * DL - REAL array ( I or J, as appropriate ) * Left scale factors for grading matrix. Not modified. * * DR - REAL array ( I or J, as appropriate ) * Right scale factors for grading matrix. Not modified. * * IPVTNG - INTEGER * On entry specifies pivoting permutations as follows: * 0 => none. * 1 => row pivoting. * 2 => column pivoting. * 3 => full pivoting, i.e., on both sides. * Not modified. * * IWORK - INTEGER array ( I or J, as appropriate ) * This array specifies the permutation used. The * row (or column) in position K was originally in * position IWORK( K ). * This differs from IWORK for SLATM3. Not modified. * * SPARSE - REAL between 0. and 1. * On entry specifies the sparsity of the matrix * if sparse matix is to be generated. * SPARSE should lie between 0 and 1. * A uniform ( 0, 1 ) random number x is generated and * compared to SPARSE; if x is larger the matrix entry * is unchanged and if x is smaller the entry is set * to zero. Thus on the average a fraction SPARSE of the * entries will be set to zero. * Not modified. * * ===================================================================== * * .. Parameters .. * REAL ZERO PARAMETER ( ZERO = 0.0E0 ) * .. * * .. Local Scalars .. * INTEGER ISUB, JSUB REAL TEMP * .. * * .. External Functions .. * REAL SLARAN, SLARND EXTERNAL SLARAN, SLARND * .. * *----------------------------------------------------------------------- * * .. Executable Statements .. * * * Check for I and J in range * IF( I.LT.1 .OR. I.GT.M .OR. J.LT.1 .OR. J.GT.N ) THEN SLATM2 = ZERO RETURN END IF * * Check for banding * IF( J.GT.I+KU .OR. J.LT.I-KL ) THEN SLATM2 = ZERO RETURN END IF * * Check for sparsity * IF( SPARSE.GT.ZERO ) THEN IF( SLARAN( ISEED ).LT.SPARSE ) THEN SLATM2 = ZERO RETURN END IF END IF * * Compute subscripts depending on IPVTNG * IF( IPVTNG.EQ.0 ) THEN ISUB = I JSUB = J ELSE IF( IPVTNG.EQ.1 ) THEN ISUB = IWORK( I ) JSUB = J ELSE IF( IPVTNG.EQ.2 ) THEN ISUB = I JSUB = IWORK( J ) ELSE IF( IPVTNG.EQ.3 ) THEN ISUB = IWORK( I ) JSUB = IWORK( J ) END IF * * Compute entry and grade it according to IGRADE * IF( ISUB.EQ.JSUB ) THEN TEMP = D( ISUB ) ELSE TEMP = SLARND( IDIST, ISEED ) END IF IF( IGRADE.EQ.1 ) THEN TEMP = TEMP*DL( ISUB ) ELSE IF( IGRADE.EQ.2 ) THEN TEMP = TEMP*DR( JSUB ) ELSE IF( IGRADE.EQ.3 ) THEN TEMP = TEMP*DL( ISUB )*DR( JSUB ) ELSE IF( IGRADE.EQ.4 .AND. ISUB.NE.JSUB ) THEN TEMP = TEMP*DL( ISUB ) / DL( JSUB ) ELSE IF( IGRADE.EQ.5 ) THEN TEMP = TEMP*DL( ISUB )*DL( JSUB ) END IF SLATM2 = TEMP RETURN * * End of SLATM2 * END SHAR_EOF fi # end of overwriting check if test -f 'slatm3.f' then echo shar: will not over-write existing file "'slatm3.f'" else cat << SHAR_EOF > 'slatm3.f' REAL FUNCTION SLATM3( M, N, I, J, ISUB, JSUB, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, $ SPARSE ) * * -- LAPACK auxiliary test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. * INTEGER I, IDIST, IGRADE, IPVTNG, ISUB, J, JSUB, KL, $ KU, M, N REAL SPARSE * .. * * .. Array Arguments .. * INTEGER ISEED( 4 ), IWORK( * ) REAL D( * ), DL( * ), DR( * ) * .. * * Purpose * ======= * * SLATM3 returns the (ISUB,JSUB) entry of a random matrix of * dimension (M, N) described by the other paramters. (ISUB,JSUB) * is the final position of the (I,J) entry after pivoting * according to IPVTNG and IWORK. SLATM3 is called by the * SLATMR routine in order to build random test matrices. No error * checking on parameters is done, because this routine is called in * a tight loop by SLATMR which has already checked the parameters. * * Use of SLATM3 differs from SLATM2 in the order in which the random * number generator is called to fill in random matrix entries. * With SLATM2, the generator is called to fill in the pivoted matrix * columnwise. With SLATM3, the generator is called to fill in the * matrix columnwise, after which it is pivoted. Thus, SLATM3 can * be used to construct random matrices which differ only in their * order of rows and/or columns. SLATM2 is used to construct band * matrices while avoiding calling the random number generator for * entries outside the band (and therefore generating random numbers * in different orders for different pivot orders). * * The matrix whose (ISUB,JSUB) entry is returned is constructed as * follows (this routine only computes one entry): * * If ISUB is outside (1..M) or JSUB is outside (1..N), return zero * (this is convenient for generating matrices in band format). * * Generate a matrix A with random entries of distribution IDIST. * * Set the diagonal to D. * * Grade the matrix, if desired, from the left (by DL) and/or * from the right (by DR or DL) as specified by IGRADE. * * Permute, if desired, the rows and/or columns as specified by * IPVTNG and IWORK. * * Band the matrix to have lower bandwidth KL and upper * bandwidth KU. * * Set random entries to zero as specified by SPARSE. * * Arguments * ========= * * M - INTEGER * Number of rows of matrix. Not modified. * * N - INTEGER * Number of columns of matrix. Not modified. * * I - INTEGER * Row of unpivoted entry to be returned. Not modified. * * J - INTEGER * Column of unpivoted entry to be returned. Not modified. * * ISUB - INTEGER * Row of pivoted entry to be returned. Changed on exit. * * JSUB - INTEGER * Column of pivoted entry to be returned. Changed on exit. * * KL - INTEGER * Lower bandwidth. Not modified. * * KU - INTEGER * Upper bandwidth. Not modified. * * IDIST - INTEGER * On entry, IDIST specifies the type of distribution to be * used to generate a random matrix . * 1 => UNIFORM( 0, 1 ) * 2 => UNIFORM( -1, 1 ) * 3 => NORMAL( 0, 1 ) * Not modified. * * ISEED - INTEGER array of dimension ( 4 ) * Seed for random number generator. * Changed on exit. * * D - REAL array of dimension ( MIN( I , J ) ) * Diagonal entries of matrix. Not modified. * * IGRADE - INTEGER * Specifies grading of matrix as follows: * 0 => no grading * 1 => matrix premultiplied by diag( DL ) * 2 => matrix postmultiplied by diag( DR ) * 3 => matrix premultiplied by diag( DL ) and * postmultiplied by diag( DR ) * 4 => matrix premultiplied by diag( DL ) and * postmultiplied by inv( diag( DL ) ) * 5 => matrix premultiplied by diag( DL ) and * postmultiplied by diag( DL ) * Not modified. * * DL - REAL array ( I or J, as appropriate ) * Left scale factors for grading matrix. Not modified. * * DR - REAL array ( I or J, as appropriate ) * Right scale factors for grading matrix. Not modified. * * IPVTNG - INTEGER * On entry specifies pivoting permutations as follows: * 0 => none. * 1 => row pivoting. * 2 => column pivoting. * 3 => full pivoting, i.e., on both sides. * Not modified. * * IWORK - INTEGER array ( I or J, as appropriate ) * This array specifies the permutation used. The * row (or column) originally in position K is in * position IWORK( K ) after pivoting. * This differs from IWORK for SLATM2. Not modified. * * SPARSE - REAL between 0. and 1. * On entry specifies the sparsity of the matrix * if sparse matix is to be generated. * SPARSE should lie between 0 and 1. * A uniform ( 0, 1 ) random number x is generated and * compared to SPARSE; if x is larger the matrix entry * is unchanged and if x is smaller the entry is set * to zero. Thus on the average a fraction SPARSE of the * entries will be set to zero. * Not modified. * * ===================================================================== * * .. Parameters .. * REAL ZERO PARAMETER ( ZERO = 0.0E0 ) * .. * * .. Local Scalars .. * REAL TEMP * .. * * .. External Functions .. * REAL SLARAN, SLARND EXTERNAL SLARAN, SLARND * .. * *----------------------------------------------------------------------- * * .. Executable Statements .. * * * Check for I and J in range * IF( I.LT.1 .OR. I.GT.M .OR. J.LT.1 .OR. J.GT.N ) THEN ISUB = I JSUB = J SLATM3 = ZERO RETURN END IF * * Compute subscripts depending on IPVTNG * IF( IPVTNG.EQ.0 ) THEN ISUB = I JSUB = J ELSE IF( IPVTNG.EQ.1 ) THEN ISUB = IWORK( I ) JSUB = J ELSE IF( IPVTNG.EQ.2 ) THEN ISUB = I JSUB = IWORK( J ) ELSE IF( IPVTNG.EQ.3 ) THEN ISUB = IWORK( I ) JSUB = IWORK( J ) END IF * * Check for banding * IF( JSUB.GT.ISUB+KU .OR. JSUB.LT.ISUB-KL ) THEN SLATM3 = ZERO RETURN END IF * * Check for sparsity * IF( SPARSE.GT.ZERO ) THEN IF( SLARAN( ISEED ).LT.SPARSE ) THEN SLATM3 = ZERO RETURN END IF END IF * * Compute entry and grade it according to IGRADE * IF( I.EQ.J ) THEN TEMP = D( I ) ELSE TEMP = SLARND( IDIST, ISEED ) END IF IF( IGRADE.EQ.1 ) THEN TEMP = TEMP*DL( I ) ELSE IF( IGRADE.EQ.2 ) THEN TEMP = TEMP*DR( J ) ELSE IF( IGRADE.EQ.3 ) THEN TEMP = TEMP*DL( I )*DR( J ) ELSE IF( IGRADE.EQ.4 .AND. I.NE.J ) THEN TEMP = TEMP*DL( I ) / DL( J ) ELSE IF( IGRADE.EQ.5 ) THEN TEMP = TEMP*DL( I )*DL( J ) END IF SLATM3 = TEMP RETURN * * End of SLATM3 * END SHAR_EOF fi # end of overwriting check if test -f 'slatme.f' then echo shar: will not over-write existing file "'slatme.f'" else cat << SHAR_EOF > 'slatme.f' SUBROUTINE SLATME( N, DIST, ISEED, D, MODE, COND, DMAX, EI, RSIGN, $ UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, A, $ LDA, WORK, INFO ) * * -- LAPACK test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER DIST, RSIGN, SIM, UPPER INTEGER INFO, KL, KU, LDA, MODE, MODES, N REAL ANORM, COND, CONDS, DMAX * .. * .. Array Arguments .. CHARACTER EI( * ) INTEGER ISEED( 4 ) REAL A( LDA, * ), D( * ), DS( * ), WORK( * ) * .. * * Purpose * ======= * * SLATME generates random non-symmetric square matrices with * specified eigenvalues for testing LAPACK programs. * * SLATME operates by applying the following sequence of * operations: * * 1. Set the diagonal to D, where D may be input or * computed according to MODE, COND, DMAX, and RSIGN * as described below. * * 2. If complex conjugate pairs are desired (MODE=0 and EI(1)='R', * or MODE=5), certain pairs of adjacent elements of D are * interpreted as the real and complex parts of a complex * conjugate pair; A thus becomes block diagonal, with 1x1 * and 2x2 blocks. * * 3. If UPPER='T', the upper triangle of A is set to random values * out of distribution DIST. * * 4. If SIM='T', A is multiplied on the left by a random matrix * X, whose singular values are specified by DS, MODES, and * CONDS, and on the right by X inverse. * * 5. If KL < N-1, the lower bandwidth is reduced to KL using * Householder transformations. If KU < N-1, the upper * bandwidth is reduced to KU. * * 6. If ANORM is not negative, the matrix is scaled to have * maximum-element-norm ANORM. * * (Note: since the matrix cannot be reduced beyond Hessenberg form, * no packing options are available.) * * Arguments * ========= * * N - INTEGER * The number of columns (or rows) of A. Not modified. * * DIST - CHARACTER*1 * On entry, DIST specifies the type of distribution to be used * to generate the random eigen-/singular values, and for the * upper triangle (see UPPER). * 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) * 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) * 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) * Not modified. * * ISEED - INTEGER array, dimension ( 4 ) * On entry ISEED specifies the seed of the random number * generator. They should lie between 0 and 4095 inclusive, * and ISEED(4) should be odd. The random number generator * uses a linear congruential sequence limited to small * integers, and so should produce machine independent * random numbers. The values of ISEED are changed on * exit, and can be used in the next call to SLATME * to continue the same random number sequence. * Changed on exit. * * D - REAL array, dimension ( N ) * This array is used to specify the eigenvalues of A. If * MODE=0, then D is assumed to contain the eigenvalues (but * see the description of EI), otherwise they will be * computed according to MODE, COND, DMAX, and RSIGN and * placed in D. * Modified if MODE is nonzero. * * MODE - INTEGER * On entry this describes how the eigenvalues are to * be specified: * MODE = 0 means use D (with EI) as input * MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND * MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND * MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) * MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) * MODE = 5 sets D to random numbers in the range * ( 1/COND , 1 ) such that their logarithms * are uniformly distributed. Each odd-even pair * of elements will be either used as two real * eigenvalues or as the real and imaginary part * of a complex conjugate pair of eigenvalues; * the choice of which is done is random, with * 50-50 probability, for each pair. * MODE = 6 set D to random numbers from same distribution * as the rest of the matrix. * MODE < 0 has the same meaning as ABS(MODE), except that * the order of the elements of D is reversed. * Thus if MODE is between 1 and 4, D has entries ranging * from 1 to 1/COND, if between -1 and -4, D has entries * ranging from 1/COND to 1, * Not modified. * * COND - REAL * On entry, this is used as described under MODE above. * If used, it must be >= 1. Not modified. * * DMAX - REAL * If MODE is neither -6, 0 nor 6, the contents of D, as * computed according to MODE and COND, will be scaled by * DMAX / max(abs(D(i))). Note that DMAX need not be * positive: if DMAX is negative (or zero), D will be * scaled by a negative number (or zero). * Not modified. * * EI - CHARACTER*1 array, dimension ( N ) * If MODE is 0, and EI(1) is not ' ' (space character), * this array specifies which elements of D (on input) are * real eigenvalues and which are the real and imaginary parts * of a complex conjugate pair of eigenvalues. The elements * of EI may then only have the values 'R' and 'I'. If * EI(j)='R' and EI(j+1)='I', then the j-th eigenvalue is * CMPLX( D(j) , D(j+1) ), and the (j+1)-th is the complex * conjugate thereof. If EI(j)=EI(j+1)='R', then the j-th * eigenvalue is D(j) (i.e., real). EI(1) may not be 'I', * nor may two adjacent elements of EI both have the value 'I'. * If MODE is not 0, then EI is ignored. If MODE is 0 and * EI(1)=' ', then the eigenvalues will all be real. * Not modified. * * RSIGN - CHARACTER*1 * If MODE is not 0, 6, or -6, and RSIGN='T', then the * elements of D, as computed according to MODE and COND, will * be multiplied by a random sign (+1 or -1). If RSIGN='F', * they will not be. RSIGN may only have the values 'T' or * 'F'. * Not modified. * * UPPER - CHARACTER*1 * If UPPER='T', then the elements of A above the diagonal * (and above the 2x2 diagonal blocks, if A has complex * eigenvalues) will be set to random numbers out of DIST. * If UPPER='F', they will not. UPPER may only have the * values 'T' or 'F'. * Not modified. * * SIM - CHARACTER*1 * If SIM='T', then A will be operated on by a "similarity * transform", i.e., multiplied on the left by a matrix X and * on the right by X inverse. X = U S V, where U and V are * random unitary matrices and S is a (diagonal) matrix of * singular values specified by DS, MODES, and CONDS. If * SIM='F', then A will not be transformed. * Not modified. * * DS - REAL array, dimension ( N ) * This array is used to specify the singular values of X, * in the same way that D specifies the eigenvalues of A. * If MODE=0, the DS contains the singular values, which * may not be zero. * Modified if MODE is nonzero. * * MODES - INTEGER * CONDS - REAL * Same as MODE and COND, but for specifying the diagonal * of S. MODES=-6 and +6 are not allowed (since they would * result in randomly ill-conditioned eigenvalues.) * * KL - INTEGER * This specifies the lower bandwidth of the matrix. KL=1 * specifies upper Hessenberg form. If KL is at least N-1, * then A will have full lower bandwidth. KL must be at * least 1. * Not modified. * * KU - INTEGER * This specifies the upper bandwidth of the matrix. KU=1 * specifies lower Hessenberg form. If KU is at least N-1, * then A will have full upper bandwidth; if KU and KL * are both at least N-1, then A will be dense. Only one of * KU and KL may be less than N-1. KU must be at least 1. * Not modified. * * ANORM - REAL * If ANORM is not negative, then A will be scaled by a non- * negative real number to make the maximum-element-norm of A * to be ANORM. * Not modified. * * A - REAL array, dimension ( LDA, N ) * On exit A is the desired test matrix. * Modified. * * LDA - INTEGER * LDA specifies the first dimension of A as declared in the * calling program. LDA must be at least N. * Not modified. * * WORK - REAL array, dimension ( 3*N ) * Workspace. * Modified. * * INFO - INTEGER * Error code. On exit, INFO will be set to one of the * following values: * 0 => normal return * -1 => N negative * -2 => DIST illegal string * -5 => MODE not in range -6 to 6 * -6 => COND less than 1.0, and MODE neither -6, 0 nor 6 * -8 => EI(1) is not ' ' or 'R', EI(j) is not 'R' or 'I', or * two adjacent elements of EI are 'I'. * -9 => RSIGN is not 'T' or 'F' * -10 => UPPER is not 'T' or 'F' * -11 => SIM is not 'T' or 'F' * -12 => MODES=0 and DS has a zero singular value. * -13 => MODES is not in the range -5 to 5. * -14 => MODES is nonzero and CONDS is less than 1. * -15 => KL is less than 1. * -16 => KU is less than 1, or KL and KU are both less than * N-1. * -19 => LDA is less than N. * 1 => Error return from SLATM1 (computing D) * 2 => Cannot scale to DMAX (max. eigenvalue is 0) * 3 => Error return from SLATM1 (computing DS) * 4 => Error return from SLARGE * 5 => Zero singular value from SLATM1. * * ===================================================================== * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E0 ) REAL ONE PARAMETER ( ONE = 1.0E0 ) REAL HALF PARAMETER ( HALF = 1.0E0 / 2.0E0 ) * .. * .. Local Scalars .. LOGICAL BADEI, BADS, USEEI INTEGER I, IC, ICOLS, IDIST, IINFO, IR, IROWS, IRSIGN, $ ISIM, IUPPER, J, JC, JCR, JR REAL ALPHA, TAU, TEMP, XNORMS * .. * .. Local Arrays .. REAL TEMPA( 1 ) * .. * .. External Functions .. LOGICAL LSAME REAL SLANGE, SLARAN EXTERNAL LSAME, SLANGE, SLARAN * .. * .. External Subroutines .. EXTERNAL SCOPY, SGEMV, SGER, SLARFG, SLARGE, SLARNV, $ SLATM1, SLASET, SSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MOD * .. * .. Executable Statements .. * * 1) Decode and Test the input parameters. * Initialize flags & seed. * INFO = 0 * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Decode DIST * IF( LSAME( DIST, 'U' ) ) THEN IDIST = 1 ELSE IF( LSAME( DIST, 'S' ) ) THEN IDIST = 2 ELSE IF( LSAME( DIST, 'N' ) ) THEN IDIST = 3 ELSE IDIST = -1 END IF * * Check EI * USEEI = .TRUE. BADEI = .FALSE. IF( LSAME( EI( 1 ), ' ' ) .OR. MODE.NE.0 ) THEN USEEI = .FALSE. ELSE IF( LSAME( EI( 1 ), 'R' ) ) THEN DO 10 J = 2, N IF( LSAME( EI( J ), 'I' ) ) THEN IF( LSAME( EI( J-1 ), 'I' ) ) $ BADEI = .TRUE. ELSE IF( .NOT.LSAME( EI( J ), 'R' ) ) $ BADEI = .TRUE. END IF 10 CONTINUE ELSE BADEI = .TRUE. END IF END IF * * Decode RSIGN * IF( LSAME( RSIGN, 'T' ) ) THEN IRSIGN = 1 ELSE IF( LSAME( RSIGN, 'F' ) ) THEN IRSIGN = 0 ELSE IRSIGN = -1 END IF * * Decode UPPER * IF( LSAME( UPPER, 'T' ) ) THEN IUPPER = 1 ELSE IF( LSAME( UPPER, 'F' ) ) THEN IUPPER = 0 ELSE IUPPER = -1 END IF * * Decode SIM * IF( LSAME( SIM, 'T' ) ) THEN ISIM = 1 ELSE IF( LSAME( SIM, 'F' ) ) THEN ISIM = 0 ELSE ISIM = -1 END IF * * Check DS, if MODES=0 and ISIM=1 * BADS = .FALSE. IF( MODES.EQ.0 .AND. ISIM.EQ.1 ) THEN DO 20 J = 1, N IF( DS( J ).EQ.ZERO ) $ BADS = .TRUE. 20 CONTINUE END IF * * Set INFO if an error * IF( N.LT.0 ) THEN INFO = -1 ELSE IF( IDIST.EQ.-1 ) THEN INFO = -2 ELSE IF( ABS( MODE ).GT.6 ) THEN INFO = -5 ELSE IF( ( MODE.NE.0 .AND. ABS( MODE ).NE.6 ) .AND. COND.LT.ONE ) $ THEN INFO = -6 ELSE IF( BADEI ) THEN INFO = -8 ELSE IF( IRSIGN.EQ.-1 ) THEN INFO = -9 ELSE IF( IUPPER.EQ.-1 ) THEN INFO = -10 ELSE IF( ISIM.EQ.-1 ) THEN INFO = -11 ELSE IF( BADS ) THEN INFO = -12 ELSE IF( ISIM.EQ.1 .AND. ABS( MODES ).GT.5 ) THEN INFO = -13 ELSE IF( ISIM.EQ.1 .AND. MODES.NE.0 .AND. CONDS.LT.ONE ) THEN INFO = -14 ELSE IF( KL.LT.1 ) THEN INFO = -15 ELSE IF( KU.LT.1 .OR. ( KU.LT.N-1 .AND. KL.LT.N-1 ) ) THEN INFO = -16 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -19 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'SLATME', -INFO ) RETURN END IF * * Initialize random number generator * DO 30 I = 1, 4 ISEED( I ) = MOD( ABS( ISEED( I ) ), 4096 ) 30 CONTINUE * IF( MOD( ISEED( 4 ), 2 ).NE.1 ) $ ISEED( 4 ) = ISEED( 4 ) + 1 * * 2) Set up diagonal of A * * Compute D according to COND and MODE * CALL SLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, IINFO ) IF( IINFO.NE.0 ) THEN INFO = 1 RETURN END IF IF( MODE.NE.0 .AND. ABS( MODE ).NE.6 ) THEN * * Scale by DMAX * TEMP = ABS( D( 1 ) ) DO 40 I = 2, N TEMP = MAX( TEMP, ABS( D( I ) ) ) 40 CONTINUE * IF( TEMP.GT.ZERO ) THEN ALPHA = DMAX / TEMP ELSE IF( DMAX.NE.ZERO ) THEN INFO = 2 RETURN ELSE ALPHA = ZERO END IF * CALL SSCAL( N, ALPHA, D, 1 ) * END IF * CALL SLASET( 'Full', N, N, ZERO, ZERO, A, LDA ) CALL SCOPY( N, D, 1, A, LDA+1 ) * * Set up complex conjugate pairs * IF( MODE.EQ.0 ) THEN IF( USEEI ) THEN DO 50 J = 2, N IF( LSAME( EI( J ), 'I' ) ) THEN A( J-1, J ) = A( J, J ) A( J, J-1 ) = -A( J, J ) A( J, J ) = A( J-1, J-1 ) END IF 50 CONTINUE END IF * ELSE IF( ABS( MODE ).EQ.5 ) THEN * DO 60 J = 2, N, 2 IF( SLARAN( ISEED ).GT.HALF ) THEN A( J-1, J ) = A( J, J ) A( J, J-1 ) = -A( J, J ) A( J, J ) = A( J-1, J-1 ) END IF 60 CONTINUE END IF * * 3) If UPPER='T', set upper triangle of A to random numbers. * (but don't modify the corners of 2x2 blocks.) * IF( IUPPER.NE.0 ) THEN DO 70 JC = 2, N IF( A( JC-1, JC ).NE.ZERO ) THEN JR = JC - 2 ELSE JR = JC - 1 END IF CALL SLARNV( IDIST, ISEED, JR, A( 1, JC ) ) 70 CONTINUE END IF * * 4) If SIM='T', apply similarity transformation. * * -1 * Transform is X A X , where X = U S V, thus * * it is U S V A V' (1/S) U' * IF( ISIM.NE.0 ) THEN * * Compute S (singular values of the eigenvector matrix) * according to CONDS and MODES * CALL SLATM1( MODES, CONDS, 0, 0, ISEED, DS, N, IINFO ) IF( IINFO.NE.0 ) THEN INFO = 3 RETURN END IF * * Multiply by V and V' * CALL SLARGE( N, A, LDA, ISEED, WORK, IINFO ) IF( IINFO.NE.0 ) THEN INFO = 4 RETURN END IF * * Multiply by S and (1/S) * DO 80 J = 1, N CALL SSCAL( N, DS( J ), A( J, 1 ), LDA ) IF( DS( J ).NE.ZERO ) THEN CALL SSCAL( N, ONE / DS( J ), A( 1, J ), 1 ) ELSE INFO = 5 RETURN END IF 80 CONTINUE * * Multiply by U and U' * CALL SLARGE( N, A, LDA, ISEED, WORK, IINFO ) IF( IINFO.NE.0 ) THEN INFO = 4 RETURN END IF END IF * * 5) Reduce the bandwidth. * IF( KL.LT.N-1 ) THEN * * Reduce bandwidth -- kill column * DO 90 JCR = KL + 1, N - 1 IC = JCR - KL IROWS = N + 1 - JCR ICOLS = N + KL - JCR * CALL SCOPY( IROWS, A( JCR, IC ), 1, WORK, 1 ) XNORMS = WORK( 1 ) CALL SLARFG( IROWS, XNORMS, WORK( 2 ), 1, TAU ) WORK( 1 ) = ONE * CALL SGEMV( 'T', IROWS, ICOLS, ONE, A( JCR, IC+1 ), LDA, $ WORK, 1, ZERO, WORK( IROWS+1 ), 1 ) CALL SGER( IROWS, ICOLS, -TAU, WORK, 1, WORK( IROWS+1 ), 1, $ A( JCR, IC+1 ), LDA ) * CALL SGEMV( 'N', N, IROWS, ONE, A( 1, JCR ), LDA, WORK, 1, $ ZERO, WORK( IROWS+1 ), 1 ) CALL SGER( N, IROWS, -TAU, WORK( IROWS+1 ), 1, WORK, 1, $ A( 1, JCR ), LDA ) * A( JCR, IC ) = XNORMS CALL SLASET( 'Full', IROWS-1, 1, ZERO, ZERO, A( JCR+1, IC ), $ LDA ) 90 CONTINUE ELSE IF( KU.LT.N-1 ) THEN * * Reduce upper bandwidth -- kill a row at a time. * DO 100 JCR = KU + 1, N - 1 IR = JCR - KU IROWS = N + KU - JCR ICOLS = N + 1 - JCR * CALL SCOPY( ICOLS, A( IR, JCR ), LDA, WORK, 1 ) XNORMS = WORK( 1 ) CALL SLARFG( ICOLS, XNORMS, WORK( 2 ), 1, TAU ) WORK( 1 ) = ONE * CALL SGEMV( 'N', IROWS, ICOLS, ONE, A( IR+1, JCR ), LDA, $ WORK, 1, ZERO, WORK( ICOLS+1 ), 1 ) CALL SGER( IROWS, ICOLS, -TAU, WORK( ICOLS+1 ), 1, WORK, 1, $ A( IR+1, JCR ), LDA ) * CALL SGEMV( 'C', ICOLS, N, ONE, A( JCR, 1 ), LDA, WORK, 1, $ ZERO, WORK( ICOLS+1 ), 1 ) CALL SGER( ICOLS, N, -TAU, WORK, 1, WORK( ICOLS+1 ), 1, $ A( JCR, 1 ), LDA ) * A( IR, JCR ) = XNORMS CALL SLASET( 'Full', 1, ICOLS-1, ZERO, ZERO, A( IR, JCR+1 ), $ LDA ) 100 CONTINUE END IF * * Scale the matrix to have norm ANORM * IF( ANORM.GE.ZERO ) THEN TEMP = SLANGE( 'M', N, N, A, LDA, TEMPA ) IF( TEMP.GT.ZERO ) THEN ALPHA = ANORM / TEMP DO 110 J = 1, N CALL SSCAL( N, ALPHA, A( 1, J ), 1 ) 110 CONTINUE END IF END IF * RETURN * * End of SLATME * END SHAR_EOF fi # end of overwriting check if test -f 'slatmr.f' then echo shar: will not over-write existing file "'slatmr.f'" else cat << SHAR_EOF > 'slatmr.f' SUBROUTINE SLATMR( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, $ RSIGN, GRADE, DL, MODEL, CONDL, DR, MODER, $ CONDR, PIVTNG, IPIVOT, KL, KU, SPARSE, ANORM, $ PACK, A, LDA, IWORK, INFO ) * * -- LAPACK test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER DIST, GRADE, PACK, PIVTNG, RSIGN, SYM INTEGER INFO, KL, KU, LDA, M, MODE, MODEL, MODER, N REAL ANORM, COND, CONDL, CONDR, DMAX, SPARSE * .. * .. Array Arguments .. INTEGER IPIVOT( * ), ISEED( 4 ), IWORK( * ) REAL A( LDA, * ), D( * ), DL( * ), DR( * ) * .. * * Purpose * ======= * * SLATMR generates random matrices of various types for testing * LAPACK programs. * * SLATMR operates by applying the following sequence of * operations: * * Generate a matrix A with random entries of distribution DIST * which is symmetric if SYM='S', and nonsymmetric * if SYM='N'. * * Set the diagonal to D, where D may be input or * computed according to MODE, COND, DMAX and RSIGN * as described below. * * Grade the matrix, if desired, from the left and/or right * as specified by GRADE. The inputs DL, MODEL, CONDL, DR, * MODER and CONDR also determine the grading as described * below. * * Permute, if desired, the rows and/or columns as specified by * PIVTNG and IPIVOT. * * Set random entries to zero, if desired, to get a random sparse * matrix as specified by SPARSE. * * Make A a band matrix, if desired, by zeroing out the matrix * outside a band of lower bandwidth KL and upper bandwidth KU. * * Scale A, if desired, to have maximum entry ANORM. * * Pack the matrix if desired. Options specified by PACK are: * no packing * zero out upper half (if symmetric) * zero out lower half (if symmetric) * store the upper half columnwise (if symmetric or * square upper triangular) * store the lower half columnwise (if symmetric or * square lower triangular) * same as upper half rowwise if symmetric * store the lower triangle in banded format (if symmetric) * store the upper triangle in banded format (if symmetric) * store the entire matrix in banded format * * Note: If two calls to SLATMR differ only in the PACK parameter, * they will generate mathematically equivalent matrices. * * If two calls to SLATMR both have full bandwidth (KL = M-1 * and KU = N-1), and differ only in the PIVTNG and PACK * parameters, then the matrices generated will differ only * in the order of the rows and/or columns, and otherwise * contain the same data. This consistency cannot be and * is not maintained with less than full bandwidth. * * Arguments * ========= * * M - INTEGER * Number of rows of A. Not modified. * * N - INTEGER * Number of columns of A. Not modified. * * DIST - CHARACTER*1 * On entry, DIST specifies the type of distribution to be used * to generate a random matrix . * 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) * 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) * 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) * Not modified. * * ISEED - INTEGER array, dimension (4) * On entry ISEED specifies the seed of the random number * generator. They should lie between 0 and 4095 inclusive, * and ISEED(4) should be odd. The random number generator * uses a linear congruential sequence limited to small * integers, and so should produce machine independent * random numbers. The values of ISEED are changed on * exit, and can be used in the next call to SLATMR * to continue the same random number sequence. * Changed on exit. * * SYM - CHARACTER*1 * If SYM='S' or 'H', generated matrix is symmetric. * If SYM='N', generated matrix is nonsymmetric. * Not modified. * * D - REAL array, dimension (min(M,N)) * On entry this array specifies the diagonal entries * of the diagonal of A. D may either be specified * on entry, or set according to MODE and COND as described * below. May be changed on exit if MODE is nonzero. * * MODE - INTEGER * On entry describes how D is to be used: * MODE = 0 means use D as input * MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND * MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND * MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) * MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) * MODE = 5 sets D to random numbers in the range * ( 1/COND , 1 ) such that their logarithms * are uniformly distributed. * MODE = 6 set D to random numbers from same distribution * as the rest of the matrix. * MODE < 0 has the same meaning as ABS(MODE), except that * the order of the elements of D is reversed. * Thus if MODE is positive, D has entries ranging from * 1 to 1/COND, if negative, from 1/COND to 1, * Not modified. * * COND - REAL * On entry, used as described under MODE above. * If used, it must be >= 1. Not modified. * * DMAX - REAL * If MODE neither -6, 0 nor 6, the diagonal is scaled by * DMAX / max(abs(D(i))), so that maximum absolute entry * of diagonal is abs(DMAX). If DMAX is negative (or zero), * diagonal will be scaled by a negative number (or zero). * * RSIGN - CHARACTER*1 * If MODE neither -6, 0 nor 6, specifies sign of diagonal * as follows: * 'T' => diagonal entries are multiplied by 1 or -1 * with probability .5 * 'F' => diagonal unchanged * Not modified. * * GRADE - CHARACTER*1 * Specifies grading of matrix as follows: * 'N' => no grading * 'L' => matrix premultiplied by diag( DL ) * (only if matrix nonsymmetric) * 'R' => matrix postmultiplied by diag( DR ) * (only if matrix nonsymmetric) * 'B' => matrix premultiplied by diag( DL ) and * postmultiplied by diag( DR ) * (only if matrix nonsymmetric) * 'S' or 'H' => matrix premultiplied by diag( DL ) and * postmultiplied by diag( DL ) * ('S' for symmetric, or 'H' for Hermitian) * 'E' => matrix premultiplied by diag( DL ) and * postmultiplied by inv( diag( DL ) ) * ( 'E' for eigenvalue invariance) * (only if matrix nonsymmetric) * Note: if GRADE='E', then M must equal N. * Not modified. * * DL - REAL array, dimension (M) * If MODEL=0, then on entry this array specifies the diagonal * entries of a diagonal matrix used as described under GRADE * above. If MODEL is not zero, then DL will be set according * to MODEL and CONDL, analogous to the way D is set according * to MODE and COND (except there is no DMAX parameter for DL). * If GRADE='E', then DL cannot have zero entries. * Not referenced if GRADE = 'N' or 'R'. Changed on exit. * * MODEL - INTEGER * This specifies how the diagonal array DL is to be computed, * just as MODE specifies how D is to be computed. * Not modified. * * CONDL - REAL * When MODEL is not zero, this specifies the condition number * of the computed DL. Not modified. * * DR - REAL array, dimension (N) * If MODER=0, then on entry this array specifies the diagonal * entries of a diagonal matrix used as described under GRADE * above. If MODER is not zero, then DR will be set according * to MODER and CONDR, analogous to the way D is set according * to MODE and COND (except there is no DMAX parameter for DR). * Not referenced if GRADE = 'N', 'L', 'H', 'S' or 'E'. * Changed on exit. * * MODER - INTEGER * This specifies how the diagonal array DR is to be computed, * just as MODE specifies how D is to be computed. * Not modified. * * CONDR - REAL * When MODER is not zero, this specifies the condition number * of the computed DR. Not modified. * * PIVTNG - CHARACTER*1 * On entry specifies pivoting permutations as follows: * 'N' or ' ' => none. * 'L' => left or row pivoting (matrix must be nonsymmetric). * 'R' => right or column pivoting (matrix must be * nonsymmetric). * 'B' or 'F' => both or full pivoting, i.e., on both sides. * In this case, M must equal N * * If two calls to SLATMR both have full bandwidth (KL = M-1 * and KU = N-1), and differ only in the PIVTNG and PACK * parameters, then the matrices generated will differ only * in the order of the rows and/or columns, and otherwise * contain the same data. This consistency cannot be * maintained with less than full bandwidth. * * IPIVOT - INTEGER array, dimension (N or M) * This array specifies the permutation used. After the * basic matrix is generated, the rows, columns, or both * are permuted. If, say, row pivoting is selected, SLATMR * starts with the *last* row and interchanges the M-th and * IPIVOT(M)-th rows, then moves to the next-to-last row, * interchanging the (M-1)-th and the IPIVOT(M-1)-th rows, * and so on. In terms of "2-cycles", the permutation is * (1 IPIVOT(1)) (2 IPIVOT(2)) ... (M IPIVOT(M)) * where the rightmost cycle is applied first. This is the * *inverse* of the effect of pivoting in LINPACK. The idea * is that factoring (with pivoting) an identity matrix * which has been inverse-pivoted in this way should * result in a pivot vector identical to IPIVOT. * Not referenced if PIVTNG = 'N'. Not modified. * * SPARSE - REAL * On entry specifies the sparsity of the matrix if a sparse * matrix is to be generated. SPARSE should lie between * 0 and 1. To generate a sparse matrix, for each matrix entry * a uniform ( 0, 1 ) random number x is generated and * compared to SPARSE; if x is larger the matrix entry * is unchanged and if x is smaller the entry is set * to zero. Thus on the average a fraction SPARSE of the * entries will be set to zero. * Not modified. * * KL - INTEGER * On entry specifies the lower bandwidth of the matrix. For * example, KL=0 implies upper triangular, KL=1 implies upper * Hessenberg, and KL at least M-1 implies the matrix is not * banded. Must equal KU if matrix is symmetric. * Not modified. * * KU - INTEGER * On entry specifies the upper bandwidth of the matrix. For * example, KU=0 implies lower triangular, KU=1 implies lower * Hessenberg, and KU at least N-1 implies the matrix is not * banded. Must equal KL if matrix is symmetric. * Not modified. * * ANORM - REAL * On entry specifies maximum entry of output matrix * (output matrix will by multiplied by a constant so that * its largest absolute entry equal ANORM) * if ANORM is nonnegative. If ANORM is negative no scaling * is done. Not modified. * * PACK - CHARACTER*1 * On entry specifies packing of matrix as follows: * 'N' => no packing * 'U' => zero out all subdiagonal entries (if symmetric) * 'L' => zero out all superdiagonal entries (if symmetric) * 'C' => store the upper triangle columnwise * (only if matrix symmetric or square upper triangular) * 'R' => store the lower triangle columnwise * (only if matrix symmetric or square lower triangular) * (same as upper half rowwise if symmetric) * 'B' => store the lower triangle in band storage scheme * (only if matrix symmetric) * 'Q' => store the upper triangle in band storage scheme * (only if matrix symmetric) * 'Z' => store the entire matrix in band storage scheme * (pivoting can be provided for by using this * option to store A in the trailing rows of * the allocated storage) * * Using these options, the various LAPACK packed and banded * storage schemes can be obtained: * GB - use 'Z' * PB, SB or TB - use 'B' or 'Q' * PP, SP or TP - use 'C' or 'R' * * If two calls to SLATMR differ only in the PACK parameter, * they will generate mathematically equivalent matrices. * Not modified. * * A - REAL array, dimension (LDA,N) * On exit A is the desired test matrix. Only those * entries of A which are significant on output * will be referenced (even if A is in packed or band * storage format). The 'unoccupied corners' of A in * band format will be zeroed out. * * LDA - INTEGER * on entry LDA specifies the first dimension of A as * declared in the calling program. * If PACK='N', 'U' or 'L', LDA must be at least max ( 1, M ). * If PACK='C' or 'R', LDA must be at least 1. * If PACK='B', or 'Q', LDA must be MIN ( KU+1, N ) * If PACK='Z', LDA must be at least KUU+KLL+1, where * KUU = MIN ( KU, N-1 ) and KLL = MIN ( KL, N-1 ) * Not modified. * * IWORK - INTEGER array, dimension ( N or M) * Workspace. Not referenced if PIVTNG = 'N'. Changed on exit. * * INFO - INTEGER * Error parameter on exit: * 0 => normal return * -1 => M negative or unequal to N and SYM='S' or 'H' * -2 => N negative * -3 => DIST illegal string * -5 => SYM illegal string * -7 => MODE not in range -6 to 6 * -8 => COND less than 1.0, and MODE neither -6, 0 nor 6 * -10 => MODE neither -6, 0 nor 6 and RSIGN illegal string * -11 => GRADE illegal string, or GRADE='E' and * M not equal to N, or GRADE='L', 'R', 'B' or 'E' and * SYM = 'S' or 'H' * -12 => GRADE = 'E' and DL contains zero * -13 => MODEL not in range -6 to 6 and GRADE= 'L', 'B', 'H', * 'S' or 'E' * -14 => CONDL less than 1.0, GRADE='L', 'B', 'H', 'S' or 'E', * and MODEL neither -6, 0 nor 6 * -16 => MODER not in range -6 to 6 and GRADE= 'R' or 'B' * -17 => CONDR less than 1.0, GRADE='R' or 'B', and * MODER neither -6, 0 nor 6 * -18 => PIVTNG illegal string, or PIVTNG='B' or 'F' and * M not equal to N, or PIVTNG='L' or 'R' and SYM='S' * or 'H' * -19 => IPIVOT contains out of range number and * PIVTNG not equal to 'N' * -20 => KL negative * -21 => KU negative, or SYM='S' or 'H' and KU not equal to KL * -22 => SPARSE not in range 0. to 1. * -24 => PACK illegal string, or PACK='U', 'L', 'B' or 'Q' * and SYM='N', or PACK='C' and SYM='N' and either KL * not equal to 0 or N not equal to M, or PACK='R' and * SYM='N', and either KU not equal to 0 or N not equal * to M * -26 => LDA too small * 1 => Error return from SLATM1 (computing D) * 2 => Cannot scale diagonal to DMAX (max. entry is 0) * 3 => Error return from SLATM1 (computing DL) * 4 => Error return from SLATM1 (computing DR) * 5 => ANORM is positive, but matrix constructed prior to * attempting to scale it to have norm ANORM, is zero * * ===================================================================== * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E0 ) REAL ONE PARAMETER ( ONE = 1.0E0 ) * .. * .. Local Scalars .. LOGICAL BADPVT, DZERO, FULBND INTEGER I, IDIST, IGRADE, IISUB, IPACK, IPVTNG, IRSIGN, $ ISUB, ISYM, J, JJSUB, JSUB, K, KLL, KUU, MNMIN, $ MNSUB, MXSUB, NPVTS REAL ALPHA, ONORM, TEMP * .. * .. Local Arrays .. REAL TEMPA( 1 ) * .. * .. External Functions .. LOGICAL LSAME REAL SLANGB, SLANGE, SLANSB, SLANSP, SLANSY, SLATM2, $ SLATM3 EXTERNAL LSAME, SLANGB, SLANGE, SLANSB, SLANSP, SLANSY, $ SLATM2, SLATM3 * .. * .. External Subroutines .. EXTERNAL SLATM1, SSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, MOD * .. * .. Executable Statements .. * * 1) Decode and Test the input parameters. * Initialize flags & seed. * INFO = 0 * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * * Decode DIST * IF( LSAME( DIST, 'U' ) ) THEN IDIST = 1 ELSE IF( LSAME( DIST, 'S' ) ) THEN IDIST = 2 ELSE IF( LSAME( DIST, 'N' ) ) THEN IDIST = 3 ELSE IDIST = -1 END IF * * Decode SYM * IF( LSAME( SYM, 'S' ) ) THEN ISYM = 0 ELSE IF( LSAME( SYM, 'N' ) ) THEN ISYM = 1 ELSE IF( LSAME( SYM, 'H' ) ) THEN ISYM = 0 ELSE ISYM = -1 END IF * * Decode RSIGN * IF( LSAME( RSIGN, 'F' ) ) THEN IRSIGN = 0 ELSE IF( LSAME( RSIGN, 'T' ) ) THEN IRSIGN = 1 ELSE IRSIGN = -1 END IF * * Decode PIVTNG * IF( LSAME( PIVTNG, 'N' ) ) THEN IPVTNG = 0 ELSE IF( LSAME( PIVTNG, ' ' ) ) THEN IPVTNG = 0 ELSE IF( LSAME( PIVTNG, 'L' ) ) THEN IPVTNG = 1 NPVTS = M ELSE IF( LSAME( PIVTNG, 'R' ) ) THEN IPVTNG = 2 NPVTS = N ELSE IF( LSAME( PIVTNG, 'B' ) ) THEN IPVTNG = 3 NPVTS = MIN( N, M ) ELSE IF( LSAME( PIVTNG, 'F' ) ) THEN IPVTNG = 3 NPVTS = MIN( N, M ) ELSE IPVTNG = -1 END IF * * Decode GRADE * IF( LSAME( GRADE, 'N' ) ) THEN IGRADE = 0 ELSE IF( LSAME( GRADE, 'L' ) ) THEN IGRADE = 1 ELSE IF( LSAME( GRADE, 'R' ) ) THEN IGRADE = 2 ELSE IF( LSAME( GRADE, 'B' ) ) THEN IGRADE = 3 ELSE IF( LSAME( GRADE, 'E' ) ) THEN IGRADE = 4 ELSE IF( LSAME( GRADE, 'H' ) .OR. LSAME( GRADE, 'S' ) ) THEN IGRADE = 5 ELSE IGRADE = -1 END IF * * Decode PACK * IF( LSAME( PACK, 'N' ) ) THEN IPACK = 0 ELSE IF( LSAME( PACK, 'U' ) ) THEN IPACK = 1 ELSE IF( LSAME( PACK, 'L' ) ) THEN IPACK = 2 ELSE IF( LSAME( PACK, 'C' ) ) THEN IPACK = 3 ELSE IF( LSAME( PACK, 'R' ) ) THEN IPACK = 4 ELSE IF( LSAME( PACK, 'B' ) ) THEN IPACK = 5 ELSE IF( LSAME( PACK, 'Q' ) ) THEN IPACK = 6 ELSE IF( LSAME( PACK, 'Z' ) ) THEN IPACK = 7 ELSE IPACK = -1 END IF * * Set certain internal parameters * MNMIN = MIN( M, N ) KLL = MIN( KL, M-1 ) KUU = MIN( KU, N-1 ) * * If inv(DL) is used, check to see if DL has a zero entry. * DZERO = .FALSE. IF( IGRADE.EQ.4 .AND. MODEL.EQ.0 ) THEN DO 10 I = 1, M IF( DL( I ).EQ.ZERO ) $ DZERO = .TRUE. 10 CONTINUE END IF * * Check values in IPIVOT * BADPVT = .FALSE. IF( IPVTNG.GT.0 ) THEN DO 20 J = 1, NPVTS IF( IPIVOT( J ).LE.0 .OR. IPIVOT( J ).GT.NPVTS ) $ BADPVT = .TRUE. 20 CONTINUE END IF * * Set INFO if an error * IF( M.LT.0 ) THEN INFO = -1 ELSE IF( M.NE.N .AND. ISYM.EQ.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( IDIST.EQ.-1 ) THEN INFO = -3 ELSE IF( ISYM.EQ.-1 ) THEN INFO = -5 ELSE IF( MODE.LT.-6 .OR. MODE.GT.6 ) THEN INFO = -7 ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND. $ COND.LT.ONE ) THEN INFO = -8 ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND. $ IRSIGN.EQ.-1 ) THEN INFO = -10 ELSE IF( IGRADE.EQ.-1 .OR. ( IGRADE.EQ.4 .AND. M.NE.N ) .OR. $ ( ( IGRADE.GE.1 .AND. IGRADE.LE.4 ) .AND. ISYM.EQ.0 ) ) $ THEN INFO = -11 ELSE IF( IGRADE.EQ.4 .AND. DZERO ) THEN INFO = -12 ELSE IF( ( IGRADE.EQ.1 .OR. IGRADE.EQ.3 .OR. IGRADE.EQ.4 .OR. $ IGRADE.EQ.5 ) .AND. ( MODEL.LT.-6 .OR. MODEL.GT.6 ) ) $ THEN INFO = -13 ELSE IF( ( IGRADE.EQ.1 .OR. IGRADE.EQ.3 .OR. IGRADE.EQ.4 .OR. $ IGRADE.EQ.5 ) .AND. ( MODEL.NE.-6 .AND. MODEL.NE.0 .AND. $ MODEL.NE.6 ) .AND. CONDL.LT.ONE ) THEN INFO = -14 ELSE IF( ( IGRADE.EQ.2 .OR. IGRADE.EQ.3 ) .AND. $ ( MODER.LT.-6 .OR. MODER.GT.6 ) ) THEN INFO = -16 ELSE IF( ( IGRADE.EQ.2 .OR. IGRADE.EQ.3 ) .AND. $ ( MODER.NE.-6 .AND. MODER.NE.0 .AND. MODER.NE.6 ) .AND. $ CONDR.LT.ONE ) THEN INFO = -17 ELSE IF( IPVTNG.EQ.-1 .OR. ( IPVTNG.EQ.3 .AND. M.NE.N ) .OR. $ ( ( IPVTNG.EQ.1 .OR. IPVTNG.EQ.2 ) .AND. ISYM.EQ.0 ) ) $ THEN INFO = -18 ELSE IF( IPVTNG.NE.0 .AND. BADPVT ) THEN INFO = -19 ELSE IF( KL.LT.0 ) THEN INFO = -20 ELSE IF( KU.LT.0 .OR. ( ISYM.EQ.0 .AND. KL.NE.KU ) ) THEN INFO = -21 ELSE IF( SPARSE.LT.ZERO .OR. SPARSE.GT.ONE ) THEN INFO = -22 ELSE IF( IPACK.EQ.-1 .OR. ( ( IPACK.EQ.1 .OR. IPACK.EQ.2 .OR. $ IPACK.EQ.5 .OR. IPACK.EQ.6 ) .AND. ISYM.EQ.1 ) .OR. $ ( IPACK.EQ.3 .AND. ISYM.EQ.1 .AND. ( KL.NE.0 .OR. M.NE. $ N ) ) .OR. ( IPACK.EQ.4 .AND. ISYM.EQ.1 .AND. ( KU.NE. $ 0 .OR. M.NE.N ) ) ) THEN INFO = -24 ELSE IF( ( ( IPACK.EQ.0 .OR. IPACK.EQ.1 .OR. IPACK.EQ.2 ) .AND. $ LDA.LT.MAX( 1, M ) ) .OR. ( ( IPACK.EQ.3 .OR. IPACK.EQ. $ 4 ) .AND. LDA.LT.1 ) .OR. ( ( IPACK.EQ.5 .OR. IPACK.EQ. $ 6 ) .AND. LDA.LT.KUU+1 ) .OR. $ ( IPACK.EQ.7 .AND. LDA.LT.KLL+KUU+1 ) ) THEN INFO = -26 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'SLATMR', -INFO ) RETURN END IF * * Decide if we can pivot consistently * FULBND = .FALSE. IF( KUU.EQ.N-1 .AND. KLL.EQ.M-1 ) $ FULBND = .TRUE. * * Initialize random number generator * DO 30 I = 1, 4 ISEED( I ) = MOD( ABS( ISEED( I ) ), 4096 ) 30 CONTINUE * ISEED( 4 ) = 2*( ISEED( 4 ) / 2 ) + 1 * * 2) Set up D, DL, and DR, if indicated. * * Compute D according to COND and MODE * CALL SLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, MNMIN, INFO ) IF( INFO.NE.0 ) THEN INFO = 1 RETURN END IF IF( MODE.NE.0 .AND. MODE.NE.-6 .AND. MODE.NE.6 ) THEN * * Scale by DMAX * TEMP = ABS( D( 1 ) ) DO 40 I = 2, MNMIN TEMP = MAX( TEMP, ABS( D( I ) ) ) 40 CONTINUE IF( TEMP.EQ.ZERO .AND. DMAX.NE.ZERO ) THEN INFO = 2 RETURN END IF IF( TEMP.NE.ZERO ) THEN ALPHA = DMAX / TEMP ELSE ALPHA = ONE END IF DO 50 I = 1, MNMIN D( I ) = ALPHA*D( I ) 50 CONTINUE * END IF * * Compute DL if grading set * IF( IGRADE.EQ.1 .OR. IGRADE.EQ.3 .OR. IGRADE.EQ.4 .OR. IGRADE.EQ. $ 5 ) THEN CALL SLATM1( MODEL, CONDL, 0, IDIST, ISEED, DL, M, INFO ) IF( INFO.NE.0 ) THEN INFO = 3 RETURN END IF END IF * * Compute DR if grading set * IF( IGRADE.EQ.2 .OR. IGRADE.EQ.3 ) THEN CALL SLATM1( MODER, CONDR, 0, IDIST, ISEED, DR, N, INFO ) IF( INFO.NE.0 ) THEN INFO = 4 RETURN END IF END IF * * 3) Generate IWORK if pivoting * IF( IPVTNG.GT.0 ) THEN DO 60 I = 1, NPVTS IWORK( I ) = I 60 CONTINUE IF( FULBND ) THEN DO 70 I = 1, NPVTS K = IPIVOT( I ) J = IWORK( I ) IWORK( I ) = IWORK( K ) IWORK( K ) = J 70 CONTINUE ELSE DO 80 I = NPVTS, 1, -1 K = IPIVOT( I ) J = IWORK( I ) IWORK( I ) = IWORK( K ) IWORK( K ) = J 80 CONTINUE END IF END IF * * 4) Generate matrices for each kind of PACKing * Always sweep matrix columnwise (if symmetric, upper * half only) so that matrix generated does not depend * on PACK * IF( FULBND ) THEN * * Use SLATM3 so matrices generated with differing PIVOTing only * differ only in the order of their rows and/or columns. * IF( IPACK.EQ.0 ) THEN IF( ISYM.EQ.0 ) THEN DO 100 J = 1, N DO 90 I = 1, J TEMP = SLATM3( M, N, I, J, ISUB, JSUB, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) A( ISUB, JSUB ) = TEMP A( JSUB, ISUB ) = TEMP 90 CONTINUE 100 CONTINUE ELSE IF( ISYM.EQ.1 ) THEN DO 120 J = 1, N DO 110 I = 1, M TEMP = SLATM3( M, N, I, J, ISUB, JSUB, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) A( ISUB, JSUB ) = TEMP 110 CONTINUE 120 CONTINUE END IF * ELSE IF( IPACK.EQ.1 ) THEN * DO 140 J = 1, N DO 130 I = 1, J TEMP = SLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, $ SPARSE ) MNSUB = MIN( ISUB, JSUB ) MXSUB = MAX( ISUB, JSUB ) A( MNSUB, MXSUB ) = TEMP IF( MNSUB.NE.MXSUB ) $ A( MXSUB, MNSUB ) = ZERO 130 CONTINUE 140 CONTINUE * ELSE IF( IPACK.EQ.2 ) THEN * DO 160 J = 1, N DO 150 I = 1, J TEMP = SLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, $ SPARSE ) MNSUB = MIN( ISUB, JSUB ) MXSUB = MAX( ISUB, JSUB ) A( MXSUB, MNSUB ) = TEMP IF( MNSUB.NE.MXSUB ) $ A( MNSUB, MXSUB ) = ZERO 150 CONTINUE 160 CONTINUE * ELSE IF( IPACK.EQ.3 ) THEN * DO 180 J = 1, N DO 170 I = 1, J TEMP = SLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, $ SPARSE ) * * Compute K = location of (ISUB,JSUB) entry in packed * array * MNSUB = MIN( ISUB, JSUB ) MXSUB = MAX( ISUB, JSUB ) K = MXSUB*( MXSUB-1 ) / 2 + MNSUB * * Convert K to (IISUB,JJSUB) location * JJSUB = ( K-1 ) / LDA + 1 IISUB = K - LDA*( JJSUB-1 ) * A( IISUB, JJSUB ) = TEMP 170 CONTINUE 180 CONTINUE * ELSE IF( IPACK.EQ.4 ) THEN * DO 200 J = 1, N DO 190 I = 1, J TEMP = SLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, $ SPARSE ) * * Compute K = location of (I,J) entry in packed array * MNSUB = MIN( ISUB, JSUB ) MXSUB = MAX( ISUB, JSUB ) IF( MNSUB.EQ.1 ) THEN K = MXSUB ELSE K = N*( N+1 ) / 2 - ( N-MNSUB+1 )*( N-MNSUB+2 ) / $ 2 + MXSUB - MNSUB + 1 END IF * * Convert K to (IISUB,JJSUB) location * JJSUB = ( K-1 ) / LDA + 1 IISUB = K - LDA*( JJSUB-1 ) * A( IISUB, JJSUB ) = TEMP 190 CONTINUE 200 CONTINUE * ELSE IF( IPACK.EQ.5 ) THEN * DO 220 J = 1, N DO 210 I = J - KUU, J IF( I.LT.1 ) THEN A( J-I+1, I+N ) = ZERO ELSE TEMP = SLATM3( M, N, I, J, ISUB, JSUB, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) MNSUB = MIN( ISUB, JSUB ) MXSUB = MAX( ISUB, JSUB ) A( MXSUB-MNSUB+1, MNSUB ) = TEMP END IF 210 CONTINUE 220 CONTINUE * ELSE IF( IPACK.EQ.6 ) THEN * DO 240 J = 1, N DO 230 I = J - KUU, J TEMP = SLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, $ SPARSE ) MNSUB = MIN( ISUB, JSUB ) MXSUB = MAX( ISUB, JSUB ) A( MNSUB-MXSUB+KUU+1, MXSUB ) = TEMP 230 CONTINUE 240 CONTINUE * ELSE IF( IPACK.EQ.7 ) THEN * IF( ISYM.EQ.0 ) THEN DO 260 J = 1, N DO 250 I = J - KUU, J TEMP = SLATM3( M, N, I, J, ISUB, JSUB, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) MNSUB = MIN( ISUB, JSUB ) MXSUB = MAX( ISUB, JSUB ) A( MNSUB-MXSUB+KUU+1, MXSUB ) = TEMP IF( I.LT.1 ) $ A( J-I+1+KUU, I+N ) = ZERO IF( I.GE.1 .AND. MNSUB.NE.MXSUB ) $ A( MXSUB-MNSUB+1+KUU, MNSUB ) = TEMP 250 CONTINUE 260 CONTINUE ELSE IF( ISYM.EQ.1 ) THEN DO 280 J = 1, N DO 270 I = J - KUU, J + KLL TEMP = SLATM3( M, N, I, J, ISUB, JSUB, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) A( ISUB-JSUB+KUU+1, JSUB ) = TEMP 270 CONTINUE 280 CONTINUE END IF * END IF * ELSE * * Use SLATM2 * IF( IPACK.EQ.0 ) THEN IF( ISYM.EQ.0 ) THEN DO 300 J = 1, N DO 290 I = 1, J A( I, J ) = SLATM2( M, N, I, J, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) A( J, I ) = A( I, J ) 290 CONTINUE 300 CONTINUE ELSE IF( ISYM.EQ.1 ) THEN DO 320 J = 1, N DO 310 I = 1, M A( I, J ) = SLATM2( M, N, I, J, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) 310 CONTINUE 320 CONTINUE END IF * ELSE IF( IPACK.EQ.1 ) THEN * DO 340 J = 1, N DO 330 I = 1, J A( I, J ) = SLATM2( M, N, I, J, KL, KU, IDIST, ISEED, $ D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE ) IF( I.NE.J ) $ A( J, I ) = ZERO 330 CONTINUE 340 CONTINUE * ELSE IF( IPACK.EQ.2 ) THEN * DO 360 J = 1, N DO 350 I = 1, J A( J, I ) = SLATM2( M, N, I, J, KL, KU, IDIST, ISEED, $ D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE ) IF( I.NE.J ) $ A( I, J ) = ZERO 350 CONTINUE 360 CONTINUE * ELSE IF( IPACK.EQ.3 ) THEN * ISUB = 0 JSUB = 1 DO 380 J = 1, N DO 370 I = 1, J ISUB = ISUB + 1 IF( ISUB.GT.LDA ) THEN ISUB = 1 JSUB = JSUB + 1 END IF A( ISUB, JSUB ) = SLATM2( M, N, I, J, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) 370 CONTINUE 380 CONTINUE * ELSE IF( IPACK.EQ.4 ) THEN * IF( ISYM.EQ.0 ) THEN DO 400 J = 1, N DO 390 I = 1, J * * Compute K = location of (I,J) entry in packed array * IF( I.EQ.1 ) THEN K = J ELSE K = N*( N+1 ) / 2 - ( N-I+1 )*( N-I+2 ) / 2 + $ J - I + 1 END IF * * Convert K to (ISUB,JSUB) location * JSUB = ( K-1 ) / LDA + 1 ISUB = K - LDA*( JSUB-1 ) * A( ISUB, JSUB ) = SLATM2( M, N, I, J, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, DR, $ IPVTNG, IWORK, SPARSE ) 390 CONTINUE 400 CONTINUE ELSE ISUB = 0 JSUB = 1 DO 420 J = 1, N DO 410 I = J, M ISUB = ISUB + 1 IF( ISUB.GT.LDA ) THEN ISUB = 1 JSUB = JSUB + 1 END IF A( ISUB, JSUB ) = SLATM2( M, N, I, J, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, DR, $ IPVTNG, IWORK, SPARSE ) 410 CONTINUE 420 CONTINUE END IF * ELSE IF( IPACK.EQ.5 ) THEN * DO 440 J = 1, N DO 430 I = J - KUU, J IF( I.LT.1 ) THEN A( J-I+1, I+N ) = ZERO ELSE A( J-I+1, I ) = SLATM2( M, N, I, J, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) END IF 430 CONTINUE 440 CONTINUE * ELSE IF( IPACK.EQ.6 ) THEN * DO 460 J = 1, N DO 450 I = J - KUU, J A( I-J+KUU+1, J ) = SLATM2( M, N, I, J, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) 450 CONTINUE 460 CONTINUE * ELSE IF( IPACK.EQ.7 ) THEN * IF( ISYM.EQ.0 ) THEN DO 480 J = 1, N DO 470 I = J - KUU, J A( I-J+KUU+1, J ) = SLATM2( M, N, I, J, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, $ DR, IPVTNG, IWORK, SPARSE ) IF( I.LT.1 ) $ A( J-I+1+KUU, I+N ) = ZERO IF( I.GE.1 .AND. I.NE.J ) $ A( J-I+1+KUU, I ) = A( I-J+KUU+1, J ) 470 CONTINUE 480 CONTINUE ELSE IF( ISYM.EQ.1 ) THEN DO 500 J = 1, N DO 490 I = J - KUU, J + KLL A( I-J+KUU+1, J ) = SLATM2( M, N, I, J, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, $ DR, IPVTNG, IWORK, SPARSE ) 490 CONTINUE 500 CONTINUE END IF * END IF * END IF * * 5) Scaling the norm * IF( IPACK.EQ.0 ) THEN ONORM = SLANGE( 'M', M, N, A, LDA, TEMPA ) ELSE IF( IPACK.EQ.1 ) THEN ONORM = SLANSY( 'M', 'U', N, A, LDA, TEMPA ) ELSE IF( IPACK.EQ.2 ) THEN ONORM = SLANSY( 'M', 'L', N, A, LDA, TEMPA ) ELSE IF( IPACK.EQ.3 ) THEN ONORM = SLANSP( 'M', 'U', N, A, TEMPA ) ELSE IF( IPACK.EQ.4 ) THEN ONORM = SLANSP( 'M', 'L', N, A, TEMPA ) ELSE IF( IPACK.EQ.5 ) THEN ONORM = SLANSB( 'M', 'L', N, KLL, A, LDA, TEMPA ) ELSE IF( IPACK.EQ.6 ) THEN ONORM = SLANSB( 'M', 'U', N, KUU, A, LDA, TEMPA ) ELSE IF( IPACK.EQ.7 ) THEN ONORM = SLANGB( 'M', N, KLL, KUU, A, LDA, TEMPA ) END IF * IF( ANORM.GE.ZERO ) THEN * IF( ANORM.GT.ZERO .AND. ONORM.EQ.ZERO ) THEN * * Desired scaling impossible * INFO = 5 RETURN * ELSE IF( ( ANORM.GT.ONE .AND. ONORM.LT.ONE ) .OR. $ ( ANORM.LT.ONE .AND. ONORM.GT.ONE ) ) THEN * * Scale carefully to avoid over / underflow * IF( IPACK.LE.2 ) THEN DO 510 J = 1, N CALL SSCAL( M, ONE / ONORM, A( 1, J ), 1 ) CALL SSCAL( M, ANORM, A( 1, J ), 1 ) 510 CONTINUE * ELSE IF( IPACK.EQ.3 .OR. IPACK.EQ.4 ) THEN * CALL SSCAL( N*( N+1 ) / 2, ONE / ONORM, A, 1 ) CALL SSCAL( N*( N+1 ) / 2, ANORM, A, 1 ) * ELSE IF( IPACK.GE.5 ) THEN * DO 520 J = 1, N CALL SSCAL( KLL+KUU+1, ONE / ONORM, A( 1, J ), 1 ) CALL SSCAL( KLL+KUU+1, ANORM, A( 1, J ), 1 ) 520 CONTINUE * END IF * ELSE * * Scale straightforwardly * IF( IPACK.LE.2 ) THEN DO 530 J = 1, N CALL SSCAL( M, ANORM / ONORM, A( 1, J ), 1 ) 530 CONTINUE * ELSE IF( IPACK.EQ.3 .OR. IPACK.EQ.4 ) THEN * CALL SSCAL( N*( N+1 ) / 2, ANORM / ONORM, A, 1 ) * ELSE IF( IPACK.GE.5 ) THEN * DO 540 J = 1, N CALL SSCAL( KLL+KUU+1, ANORM / ONORM, A( 1, J ), 1 ) 540 CONTINUE END IF * END IF * END IF * * End of SLATMR * END SHAR_EOF fi # end of overwriting check if test -f 'slatms.f' then echo shar: will not over-write existing file "'slatms.f'" else cat << SHAR_EOF > 'slatms.f' SUBROUTINE SLATMS( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, $ KL, KU, PACK, A, LDA, WORK, INFO ) * * -- LAPACK test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER DIST, PACK, SYM INTEGER INFO, KL, KU, LDA, M, MODE, N REAL COND, DMAX * .. * .. Array Arguments .. INTEGER ISEED( 4 ) REAL A( LDA, * ), D( * ), WORK( * ) * .. * * Purpose * ======= * * SLATMS generates random matrices with specified singular values * (or symmetric/hermitian with specified eigenvalues) * for testing LAPACK programs. * * SLATMS operates by applying the following sequence of * operations: * * Set the diagonal to D, where D may be input or * computed according to MODE, COND, DMAX, and SYM * as described below. * * Generate a matrix with the appropriate band structure, by one * of two methods: * * Method A: * Generate a dense M x N matrix by multiplying D on the left * and the right by random unitary matrices, then: * * Reduce the bandwidth according to KL and KU, using * Householder transformations. * * Method B: * Convert the bandwidth-0 (i.e., diagonal) matrix to a * bandwidth-1 matrix using Givens rotations, "chasing" * out-of-band elements back, much as in QR; then * convert the bandwidth-1 to a bandwidth-2 matrix, etc. * Note that for reasonably small bandwidths (relative to * M and N) this requires less storage, as a dense matrix * is not generated. Also, for symmetric matrices, only * one triangle is generated. * * Method A is chosen if the bandwidth is a large fraction of the * order of the matrix, and LDA is at least M (so a dense * matrix can be stored.) Method B is chosen if the bandwidth * is small (< 1/2 N for symmetric, < .3 N+M for * non-symmetric), or LDA is less than M and not less than the * bandwidth. * * Pack the matrix if desired. Options specified by PACK are: * no packing * zero out upper half (if symmetric) * zero out lower half (if symmetric) * store the upper half columnwise (if symmetric or upper * triangular) * store the lower half columnwise (if symmetric or lower * triangular) * store the lower triangle in banded format (if symmetric * or lower triangular) * store the upper triangle in banded format (if symmetric * or upper triangular) * store the entire matrix in banded format * If Method B is chosen, and band format is specified, then the * matrix will be generated in the band format, so no repacking * will be necessary. * * Arguments * ========= * * M - INTEGER * The number of rows of A. Not modified. * * N - INTEGER * The number of columns of A. Not modified. * * DIST - CHARACTER*1 * On entry, DIST specifies the type of distribution to be used * to generate the random eigen-/singular values. * 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) * 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) * 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) * Not modified. * * ISEED - INTEGER array, dimension ( 4 ) * On entry ISEED specifies the seed of the random number * generator. They should lie between 0 and 4095 inclusive, * and ISEED(4) should be odd. The random number generator * uses a linear congruential sequence limited to small * integers, and so should produce machine independent * random numbers. The values of ISEED are changed on * exit, and can be used in the next call to SLATMS * to continue the same random number sequence. * Changed on exit. * * SYM - CHARACTER*1 * If SYM='S' or 'H', the generated matrix is symmetric, with * eigenvalues specified by D, COND, MODE, and DMAX; they * may be positive, negative, or zero. * If SYM='P', the generated matrix is symmetric, with * eigenvalues (= singular values) specified by D, COND, * MODE, and DMAX; they will not be negative. * If SYM='N', the generated matrix is nonsymmetric, with * singular values specified by D, COND, MODE, and DMAX; * they will not be negative. * Not modified. * * D - REAL array, dimension ( MIN( M , N ) ) * This array is used to specify the singular values or * eigenvalues of A (see SYM, above.) If MODE=0, then D is * assumed to contain the singular/eigenvalues, otherwise * they will be computed according to MODE, COND, and DMAX, * and placed in D. * Modified if MODE is nonzero. * * MODE - INTEGER * On entry this describes how the singular/eigenvalues are to * be specified: * MODE = 0 means use D as input * MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND * MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND * MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) * MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) * MODE = 5 sets D to random numbers in the range * ( 1/COND , 1 ) such that their logarithms * are uniformly distributed. * MODE = 6 set D to random numbers from same distribution * as the rest of the matrix. * MODE < 0 has the same meaning as ABS(MODE), except that * the order of the elements of D is reversed. * Thus if MODE is positive, D has entries ranging from * 1 to 1/COND, if negative, from 1/COND to 1, * If SYM='S' or 'H', and MODE is neither 0, 6, nor -6, then * the elements of D will also be multiplied by a random * sign (i.e., +1 or -1.) * Not modified. * * COND - REAL * On entry, this is used as described under MODE above. * If used, it must be >= 1. Not modified. * * DMAX - REAL * If MODE is neither -6, 0 nor 6, the contents of D, as * computed according to MODE and COND, will be scaled by * DMAX / max(abs(D(i))); thus, the maximum absolute eigen- or * singular value (which is to say the norm) will be abs(DMAX). * Note that DMAX need not be positive: if DMAX is negative * (or zero), D will be scaled by a negative number (or zero). * Not modified. * * KL - INTEGER * This specifies the lower bandwidth of the matrix. For * example, KL=0 implies upper triangular, KL=1 implies upper * Hessenberg, and KL being at least M-1 means that the matrix * has full lower bandwidth. KL must equal KU if the matrix * is symmetric. * Not modified. * * KU - INTEGER * This specifies the upper bandwidth of the matrix. For * example, KU=0 implies lower triangular, KU=1 implies lower * Hessenberg, and KU being at least N-1 means that the matrix * has full upper bandwidth. KL must equal KU if the matrix * is symmetric. * Not modified. * * PACK - CHARACTER*1 * This specifies packing of matrix as follows: * 'N' => no packing * 'U' => zero out all subdiagonal entries (if symmetric) * 'L' => zero out all superdiagonal entries (if symmetric) * 'C' => store the upper triangle columnwise * (only if the matrix is symmetric or upper triangular) * 'R' => store the lower triangle columnwise * (only if the matrix is symmetric or lower triangular) * 'B' => store the lower triangle in band storage scheme * (only if matrix symmetric or lower triangular) * 'Q' => store the upper triangle in band storage scheme * (only if matrix symmetric or upper triangular) * 'Z' => store the entire matrix in band storage scheme * (pivoting can be provided for by using this * option to store A in the trailing rows of * the allocated storage) * * Using these options, the various LAPACK packed and banded * storage schemes can be obtained: * GB - use 'Z' * PB, SB or TB - use 'B' or 'Q' * PP, SP or TP - use 'C' or 'R' * * If two calls to SLATMS differ only in the PACK parameter, * they will generate mathematically equivalent matrices. * Not modified. * * A - REAL array, dimension ( LDA, N ) * On exit A is the desired test matrix. A is first generated * in full (unpacked) form, and then packed, if so specified * by PACK. Thus, the first M elements of the first N * columns will always be modified. If PACK specifies a * packed or banded storage scheme, all LDA elements of the * first N columns will be modified; the elements of the * array which do not correspond to elements of the generated * matrix are set to zero. * Modified. * * LDA - INTEGER * LDA specifies the first dimension of A as declared in the * calling program. If PACK='N', 'U', 'L', 'C', or 'R', then * LDA must be at least M. If PACK='B' or 'Q', then LDA must * be at least MIN( KL, M-1) (which is equal to MIN(KU,N-1)). * If PACK='Z', LDA must be large enough to hold the packed * array: MIN( KU, N-1) + MIN( KL, M-1) + 1. * Not modified. * * WORK - REAL array, dimension ( 3*MAX( N , M ) ) * Workspace. * Modified. * * INFO - INTEGER * Error code. On exit, INFO will be set to one of the * following values: * 0 => normal return * -1 => M negative or unequal to N and SYM='S', 'H', or 'P' * -2 => N negative * -3 => DIST illegal string * -5 => SYM illegal string * -7 => MODE not in range -6 to 6 * -8 => COND less than 1.0, and MODE neither -6, 0 nor 6 * -10 => KL negative * -11 => KU negative, or SYM='S' or 'H' and KU not equal to KL * -12 => PACK illegal string, or PACK='U' or 'L', and SYM='N'; * or PACK='C' or 'Q' and SYM='N' and KL is not zero; * or PACK='R' or 'B' and SYM='N' and KU is not zero; * or PACK='U', 'L', 'C', 'R', 'B', or 'Q', and M is not * N. * -14 => LDA is less than M, or PACK='Z' and LDA is less than * MIN(KU,N-1) + MIN(KL,M-1) + 1. * 1 => Error return from SLATM1 * 2 => Cannot scale to DMAX (max. sing. value is 0) * 3 => Error return from SLAGGE or SLAGSY * * ===================================================================== * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E0 ) REAL ONE PARAMETER ( ONE = 1.0E0 ) REAL TWOPI PARAMETER ( TWOPI = 6.2831853071795864769252867663E+0 ) * .. * .. Local Scalars .. LOGICAL GIVENS, ILEXTR, ILTEMP, TOPDWN INTEGER I, IC, ICOL, IDIST, IENDCH, IINFO, IL, ILDA, $ IOFFG, IOFFST, IPACK, IPACKG, IR, IR1, IR2, $ IROW, IRSIGN, ISKEW, ISYM, ISYMPK, J, JC, JCH, $ JKL, JKU, JR, K, LLB, MINLDA, MNMIN, MR, NC, $ UUB REAL ALPHA, ANGLE, C, DUMMY, EXTRA, S, TEMP * .. * .. External Functions .. LOGICAL LSAME REAL SLARND EXTERNAL LSAME, SLARND * .. * .. External Subroutines .. EXTERNAL SCOPY, SLAGGE, SLAGSY, SLAROT, SLARTG, SLATM1, $ SLASET, SSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, COS, MAX, MIN, MOD, REAL, SIN * .. * .. Executable Statements .. * * 1) Decode and Test the input parameters. * Initialize flags & seed. * INFO = 0 * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * * Decode DIST * IF( LSAME( DIST, 'U' ) ) THEN IDIST = 1 ELSE IF( LSAME( DIST, 'S' ) ) THEN IDIST = 2 ELSE IF( LSAME( DIST, 'N' ) ) THEN IDIST = 3 ELSE IDIST = -1 END IF * * Decode SYM * IF( LSAME( SYM, 'N' ) ) THEN ISYM = 1 IRSIGN = 0 ELSE IF( LSAME( SYM, 'P' ) ) THEN ISYM = 2 IRSIGN = 0 ELSE IF( LSAME( SYM, 'S' ) ) THEN ISYM = 2 IRSIGN = 1 ELSE IF( LSAME( SYM, 'H' ) ) THEN ISYM = 2 IRSIGN = 1 ELSE ISYM = -1 END IF * * Decode PACK * ISYMPK = 0 IF( LSAME( PACK, 'N' ) ) THEN IPACK = 0 ELSE IF( LSAME( PACK, 'U' ) ) THEN IPACK = 1 ISYMPK = 1 ELSE IF( LSAME( PACK, 'L' ) ) THEN IPACK = 2 ISYMPK = 1 ELSE IF( LSAME( PACK, 'C' ) ) THEN IPACK = 3 ISYMPK = 2 ELSE IF( LSAME( PACK, 'R' ) ) THEN IPACK = 4 ISYMPK = 3 ELSE IF( LSAME( PACK, 'B' ) ) THEN IPACK = 5 ISYMPK = 3 ELSE IF( LSAME( PACK, 'Q' ) ) THEN IPACK = 6 ISYMPK = 2 ELSE IF( LSAME( PACK, 'Z' ) ) THEN IPACK = 7 ELSE IPACK = -1 END IF * * Set certain internal parameters * MNMIN = MIN( M, N ) LLB = MIN( KL, M-1 ) UUB = MIN( KU, N-1 ) MR = MIN( M, N+LLB ) NC = MIN( N, M+UUB ) * IF( IPACK.EQ.5 .OR. IPACK.EQ.6 ) THEN MINLDA = UUB + 1 ELSE IF( IPACK.EQ.7 ) THEN MINLDA = LLB + UUB + 1 ELSE MINLDA = M END IF * * Use Givens rotation method if bandwidth small enough, * or if LDA is too small to store the matrix unpacked. * GIVENS = .FALSE. IF( ISYM.EQ.1 ) THEN IF( REAL( LLB+UUB ).LT.0.3*REAL( MAX( 1, MR+NC ) ) ) $ GIVENS = .TRUE. ELSE IF( 2*LLB.LT.M ) $ GIVENS = .TRUE. END IF IF( LDA.LT.M .AND. LDA.GE.MINLDA ) $ GIVENS = .TRUE. * * Set INFO if an error * IF( M.LT.0 ) THEN INFO = -1 ELSE IF( M.NE.N .AND. ISYM.NE.1 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( IDIST.EQ.-1 ) THEN INFO = -3 ELSE IF( ISYM.EQ.-1 ) THEN INFO = -5 ELSE IF( ABS( MODE ).GT.6 ) THEN INFO = -7 ELSE IF( ( MODE.NE.0 .AND. ABS( MODE ).NE.6 ) .AND. COND.LT.ONE ) $ THEN INFO = -8 ELSE IF( KL.LT.0 ) THEN INFO = -10 ELSE IF( KU.LT.0 .OR. ( ISYM.NE.1 .AND. KL.NE.KU ) ) THEN INFO = -11 ELSE IF( IPACK.EQ.-1 .OR. ( ISYMPK.EQ.1 .AND. ISYM.EQ.1 ) .OR. $ ( ISYMPK.EQ.2 .AND. ISYM.EQ.1 .AND. KL.GT.0 ) .OR. $ ( ISYMPK.EQ.3 .AND. ISYM.EQ.1 .AND. KU.GT.0 ) .OR. $ ( ISYMPK.NE.0 .AND. M.NE.N ) ) THEN INFO = -12 ELSE IF( LDA.LT.MAX( 1, MINLDA ) ) THEN INFO = -14 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'SLATMS', -INFO ) RETURN END IF * * Initialize random number generator * DO 10 I = 1, 4 ISEED( I ) = MOD( ABS( ISEED( I ) ), 4096 ) 10 CONTINUE * IF( MOD( ISEED( 4 ), 2 ).NE.1 ) $ ISEED( 4 ) = ISEED( 4 ) + 1 * * 2) Set up D if indicated. * * Compute D according to COND and MODE * CALL SLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, MNMIN, IINFO ) IF( IINFO.NE.0 ) THEN INFO = 1 RETURN END IF * * Choose Top-Down if D is (apparently) increasing, * Bottom-Up if D is (apparently) decreasing. * IF( ABS( D( 1 ) ).LE.ABS( D( MNMIN ) ) ) THEN TOPDWN = .TRUE. ELSE TOPDWN = .FALSE. END IF * IF( MODE.NE.0 .AND. ABS( MODE ).NE.6 ) THEN * * Scale by DMAX * TEMP = ABS( D( 1 ) ) DO 20 I = 2, MNMIN TEMP = MAX( TEMP, ABS( D( I ) ) ) 20 CONTINUE * IF( TEMP.GT.ZERO ) THEN ALPHA = DMAX / TEMP ELSE INFO = 2 RETURN END IF * CALL SSCAL( MNMIN, ALPHA, D, 1 ) * END IF * * 3) Generate Banded Matrix using Givens rotations. * Also the special case of UUB=LLB=0 * * Compute Addressing constants to cover all * storage formats. Whether GE, SY, GB, or SB, * upper or lower triangle or both, * the (i,j)-th element is in * A( i - ISKEW*j + IOFFST, j ) * IF( IPACK.GT.4 ) THEN ILDA = LDA - 1 ISKEW = 1 IF( IPACK.GT.5 ) THEN IOFFST = UUB + 1 ELSE IOFFST = 1 END IF ELSE ILDA = LDA ISKEW = 0 IOFFST = 0 END IF * * IPACKG is the format that the matrix is generated in. If this is * different from IPACK, then the matrix must be repacked at the * end. It also signals how to compute the norm, for scaling. * IPACKG = 0 CALL SLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA ) * * Diagonal Matrix -- We are done, unless it * is to be stored SP/PP/TP (PACK='R' or 'C') * IF( LLB.EQ.0 .AND. UUB.EQ.0 ) THEN CALL SCOPY( MNMIN, D, 1, A( 1-ISKEW+IOFFST, 1 ), ILDA+1 ) IF( IPACK.LE.2 .OR. IPACK.GE.5 ) $ IPACKG = IPACK * ELSE IF( GIVENS ) THEN * * Check whether to use Givens rotations, * Householder transformations, or nothing. * IF( ISYM.EQ.1 ) THEN * * Non-symmetric -- A = U D V * IF( IPACK.GT.4 ) THEN IPACKG = IPACK ELSE IPACKG = 0 END IF * CALL SCOPY( MNMIN, D, 1, A( 1-ISKEW+IOFFST, 1 ), ILDA+1 ) * IF( TOPDWN ) THEN JKL = 0 DO 50 JKU = 1, UUB * * Transform from bandwidth JKL, JKU-1 to JKL, JKU * * Last row actually rotated is M * Last column actually rotated is MIN( M+JKU, N ) * DO 40 JR = 1, MIN( M+JKU, N ) + JKL - 1 EXTRA = ZERO ANGLE = TWOPI*SLARND( 1, ISEED ) C = COS( ANGLE ) S = SIN( ANGLE ) ICOL = MAX( 1, JR-JKL ) IF( JR.LT.M ) THEN IL = MIN( N, JR+JKU ) + 1 - ICOL CALL SLAROT( .TRUE., JR.GT.JKL, .FALSE., IL, C, $ S, A( JR-ISKEW*ICOL+IOFFST, ICOL ), $ ILDA, EXTRA, DUMMY ) END IF * * Chase "EXTRA" back up * IR = JR IC = ICOL DO 30 JCH = JR - JKL, 1, -JKL - JKU IF( IR.LT.M ) THEN CALL SLARTG( A( IR+1-ISKEW*( IC+1 )+IOFFST, $ IC+1 ), EXTRA, C, S, DUMMY ) END IF IROW = MAX( 1, JCH-JKU ) IL = IR + 2 - IROW TEMP = ZERO ILTEMP = JCH.GT.JKU CALL SLAROT( .FALSE., ILTEMP, .TRUE., IL, C, -S, $ A( IROW-ISKEW*IC+IOFFST, IC ), $ ILDA, TEMP, EXTRA ) IF( ILTEMP ) THEN CALL SLARTG( A( IROW+1-ISKEW*( IC+1 )+IOFFST, $ IC+1 ), TEMP, C, S, DUMMY ) ICOL = MAX( 1, JCH-JKU-JKL ) IL = IC + 2 - ICOL EXTRA = ZERO CALL SLAROT( .TRUE., JCH.GT.JKU+JKL, .TRUE., $ IL, C, -S, A( IROW-ISKEW*ICOL+ $ IOFFST, ICOL ), ILDA, EXTRA, $ TEMP ) IC = ICOL IR = IROW END IF 30 CONTINUE 40 CONTINUE 50 CONTINUE * JKU = UUB DO 80 JKL = 1, LLB * * Transform from bandwidth JKL-1, JKU to JKL, JKU * DO 70 JC = 1, MIN( N+JKL, M ) + JKU - 1 EXTRA = ZERO ANGLE = TWOPI*SLARND( 1, ISEED ) C = COS( ANGLE ) S = SIN( ANGLE ) IROW = MAX( 1, JC-JKU ) IF( JC.LT.N ) THEN IL = MIN( M, JC+JKL ) + 1 - IROW CALL SLAROT( .FALSE., JC.GT.JKU, .FALSE., IL, C, $ S, A( IROW-ISKEW*JC+IOFFST, JC ), $ ILDA, EXTRA, DUMMY ) END IF * * Chase "EXTRA" back up * IC = JC IR = IROW DO 60 JCH = JC - JKU, 1, -JKL - JKU IF( IC.LT.N ) THEN CALL SLARTG( A( IR+1-ISKEW*( IC+1 )+IOFFST, $ IC+1 ), EXTRA, C, S, DUMMY ) END IF ICOL = MAX( 1, JCH-JKL ) IL = IC + 2 - ICOL TEMP = ZERO ILTEMP = JCH.GT.JKL CALL SLAROT( .TRUE., ILTEMP, .TRUE., IL, C, -S, $ A( IR-ISKEW*ICOL+IOFFST, ICOL ), $ ILDA, TEMP, EXTRA ) IF( ILTEMP ) THEN CALL SLARTG( A( IR+1-ISKEW*( ICOL+1 )+IOFFST, $ ICOL+1 ), TEMP, C, S, DUMMY ) IROW = MAX( 1, JCH-JKL-JKU ) IL = IR + 2 - IROW EXTRA = ZERO CALL SLAROT( .FALSE., JCH.GT.JKL+JKU, .TRUE., $ IL, C, -S, A( IROW-ISKEW*ICOL+ $ IOFFST, ICOL ), ILDA, EXTRA, $ TEMP ) IC = ICOL IR = IROW END IF 60 CONTINUE 70 CONTINUE 80 CONTINUE * ELSE * * Bottom-Up -- Start at the bottom right. * JKL = 0 DO 110 JKU = 1, UUB * * Transform from bandwidth JKL, JKU-1 to JKL, JKU * * First row actually rotated is M * First column actually rotated is MIN( M+JKU, N ) * IENDCH = MIN( M, N+JKL ) - 1 DO 100 JC = MIN( M+JKU, N ) - 1, 1 - JKL, -1 EXTRA = ZERO ANGLE = TWOPI*SLARND( 1, ISEED ) C = COS( ANGLE ) S = SIN( ANGLE ) IROW = MAX( 1, JC-JKU+1 ) IF( JC.GT.0 ) THEN IL = MIN( M, JC+JKL+1 ) + 1 - IROW CALL SLAROT( .FALSE., .FALSE., JC+JKL.LT.M, IL, $ C, S, A( IROW-ISKEW*JC+IOFFST, $ JC ), ILDA, DUMMY, EXTRA ) END IF * * Chase "EXTRA" back down * IC = JC DO 90 JCH = JC + JKL, IENDCH, JKL + JKU ILEXTR = IC.GT.0 IF( ILEXTR ) THEN CALL SLARTG( A( JCH-ISKEW*IC+IOFFST, IC ), $ EXTRA, C, S, DUMMY ) END IF IC = MAX( 1, IC ) ICOL = MIN( N-1, JCH+JKU ) ILTEMP = JCH + JKU.LT.N TEMP = ZERO CALL SLAROT( .TRUE., ILEXTR, ILTEMP, ICOL+2-IC, $ C, S, A( JCH-ISKEW*IC+IOFFST, IC ), $ ILDA, EXTRA, TEMP ) IF( ILTEMP ) THEN CALL SLARTG( A( JCH-ISKEW*ICOL+IOFFST, $ ICOL ), TEMP, C, S, DUMMY ) IL = MIN( IENDCH, JCH+JKL+JKU ) + 2 - JCH EXTRA = ZERO CALL SLAROT( .FALSE., .TRUE., $ JCH+JKL+JKU.LE.IENDCH, IL, C, S, $ A( JCH-ISKEW*ICOL+IOFFST, $ ICOL ), ILDA, TEMP, EXTRA ) IC = ICOL END IF 90 CONTINUE 100 CONTINUE 110 CONTINUE * JKU = UUB DO 140 JKL = 1, LLB * * Transform from bandwidth JKL-1, JKU to JKL, JKU * * First row actually rotated is MIN( N+JKL, M ) * First column actually rotated is N * IENDCH = MIN( N, M+JKU ) - 1 DO 130 JR = MIN( N+JKL, M ) - 1, 1 - JKU, -1 EXTRA = ZERO ANGLE = TWOPI*SLARND( 1, ISEED ) C = COS( ANGLE ) S = SIN( ANGLE ) ICOL = MAX( 1, JR-JKL+1 ) IF( JR.GT.0 ) THEN IL = MIN( N, JR+JKU+1 ) + 1 - ICOL CALL SLAROT( .TRUE., .FALSE., JR+JKU.LT.N, IL, $ C, S, A( JR-ISKEW*ICOL+IOFFST, $ ICOL ), ILDA, DUMMY, EXTRA ) END IF * * Chase "EXTRA" back down * IR = JR DO 120 JCH = JR + JKU, IENDCH, JKL + JKU ILEXTR = IR.GT.0 IF( ILEXTR ) THEN CALL SLARTG( A( IR-ISKEW*JCH+IOFFST, JCH ), $ EXTRA, C, S, DUMMY ) END IF IR = MAX( 1, IR ) IROW = MIN( M-1, JCH+JKL ) ILTEMP = JCH + JKL.LT.M TEMP = ZERO CALL SLAROT( .FALSE., ILEXTR, ILTEMP, IROW+2-IR, $ C, S, A( IR-ISKEW*JCH+IOFFST, $ JCH ), ILDA, EXTRA, TEMP ) IF( ILTEMP ) THEN CALL SLARTG( A( IROW-ISKEW*JCH+IOFFST, JCH ), $ TEMP, C, S, DUMMY ) IL = MIN( IENDCH, JCH+JKL+JKU ) + 2 - JCH EXTRA = ZERO CALL SLAROT( .TRUE., .TRUE., $ JCH+JKL+JKU.LE.IENDCH, IL, C, S, $ A( IROW-ISKEW*JCH+IOFFST, JCH ), $ ILDA, TEMP, EXTRA ) IR = IROW END IF 120 CONTINUE 130 CONTINUE 140 CONTINUE END IF * ELSE * * Symmetric -- A = U D U' * IPACKG = IPACK IOFFG = IOFFST * IF( TOPDWN ) THEN * * Top-Down -- Generate Upper triangle only * IF( IPACK.GE.5 ) THEN IPACKG = 6 IOFFG = UUB + 1 ELSE IPACKG = 1 END IF CALL SCOPY( MNMIN, D, 1, A( 1-ISKEW+IOFFG, 1 ), ILDA+1 ) * DO 170 K = 1, UUB DO 160 JC = 1, N - 1 IROW = MAX( 1, JC-K ) IL = MIN( JC+1, K+2 ) EXTRA = ZERO TEMP = A( JC-ISKEW*( JC+1 )+IOFFG, JC+1 ) ANGLE = TWOPI*SLARND( 1, ISEED ) C = COS( ANGLE ) S = SIN( ANGLE ) CALL SLAROT( .FALSE., JC.GT.K, .TRUE., IL, C, S, $ A( IROW-ISKEW*JC+IOFFG, JC ), ILDA, $ EXTRA, TEMP ) CALL SLAROT( .TRUE., .TRUE., .FALSE., $ MIN( K, N-JC )+1, C, S, $ A( ( 1-ISKEW )*JC+IOFFG, JC ), ILDA, $ TEMP, DUMMY ) * * Chase EXTRA back up the matrix * ICOL = JC DO 150 JCH = JC - K, 1, -K CALL SLARTG( A( JCH+1-ISKEW*( ICOL+1 )+IOFFG, $ ICOL+1 ), EXTRA, C, S, DUMMY ) TEMP = A( JCH-ISKEW*( JCH+1 )+IOFFG, JCH+1 ) CALL SLAROT( .TRUE., .TRUE., .TRUE., K+2, C, -S, $ A( ( 1-ISKEW )*JCH+IOFFG, JCH ), $ ILDA, TEMP, EXTRA ) IROW = MAX( 1, JCH-K ) IL = MIN( JCH+1, K+2 ) EXTRA = ZERO CALL SLAROT( .FALSE., JCH.GT.K, .TRUE., IL, C, $ -S, A( IROW-ISKEW*JCH+IOFFG, JCH ), $ ILDA, EXTRA, TEMP ) ICOL = JCH 150 CONTINUE 160 CONTINUE 170 CONTINUE * * If we need lower triangle, copy from upper. Note that * the order of copying is chosen to work for 'q' -> 'b' * IF( IPACK.NE.IPACKG .AND. IPACK.NE.3 ) THEN DO 190 JC = 1, N IROW = IOFFST - ISKEW*JC DO 180 JR = JC, MIN( N, JC+UUB ) A( JR+IROW, JC ) = A( JC-ISKEW*JR+IOFFG, JR ) 180 CONTINUE 190 CONTINUE IF( IPACK.EQ.5 ) THEN DO 210 JC = N - UUB + 1, N DO 200 JR = N + 2 - JC, UUB + 1 A( JR, JC ) = ZERO 200 CONTINUE 210 CONTINUE END IF IF( IPACKG.EQ.6 ) THEN IPACKG = IPACK ELSE IPACKG = 0 END IF END IF ELSE * * Bottom-Up -- Generate Lower triangle only * IF( IPACK.GE.5 ) THEN IPACKG = 5 IF( IPACK.EQ.6 ) $ IOFFG = 1 ELSE IPACKG = 2 END IF CALL SCOPY( MNMIN, D, 1, A( 1-ISKEW+IOFFG, 1 ), ILDA+1 ) * DO 240 K = 1, UUB DO 230 JC = N - 1, 1, -1 IL = MIN( N+1-JC, K+2 ) EXTRA = ZERO TEMP = A( 1+( 1-ISKEW )*JC+IOFFG, JC ) ANGLE = TWOPI*SLARND( 1, ISEED ) C = COS( ANGLE ) S = -SIN( ANGLE ) CALL SLAROT( .FALSE., .TRUE., N-JC.GT.K, IL, C, S, $ A( ( 1-ISKEW )*JC+IOFFG, JC ), ILDA, $ TEMP, EXTRA ) ICOL = MAX( 1, JC-K+1 ) CALL SLAROT( .TRUE., .FALSE., .TRUE., JC+2-ICOL, C, $ S, A( JC-ISKEW*ICOL+IOFFG, ICOL ), $ ILDA, DUMMY, TEMP ) * * Chase EXTRA back down the matrix * ICOL = JC DO 220 JCH = JC + K, N - 1, K CALL SLARTG( A( JCH-ISKEW*ICOL+IOFFG, ICOL ), $ EXTRA, C, S, DUMMY ) TEMP = A( 1+( 1-ISKEW )*JCH+IOFFG, JCH ) CALL SLAROT( .TRUE., .TRUE., .TRUE., K+2, C, S, $ A( JCH-ISKEW*ICOL+IOFFG, ICOL ), $ ILDA, EXTRA, TEMP ) IL = MIN( N+1-JCH, K+2 ) EXTRA = ZERO CALL SLAROT( .FALSE., .TRUE., N-JCH.GT.K, IL, C, $ S, A( ( 1-ISKEW )*JCH+IOFFG, JCH ), $ ILDA, TEMP, EXTRA ) ICOL = JCH 220 CONTINUE 230 CONTINUE 240 CONTINUE * * If we need upper triangle, copy from lower. Note that * the order of copying is chosen to work for 'b' -> 'q' * IF( IPACK.NE.IPACKG .AND. IPACK.NE.4 ) THEN DO 260 JC = N, 1, -1 IROW = IOFFST - ISKEW*JC DO 250 JR = JC, MAX( 1, JC-UUB ), -1 A( JR+IROW, JC ) = A( JC-ISKEW*JR+IOFFG, JR ) 250 CONTINUE 260 CONTINUE IF( IPACK.EQ.6 ) THEN DO 280 JC = 1, UUB DO 270 JR = 1, UUB + 1 - JC A( JR, JC ) = ZERO 270 CONTINUE 280 CONTINUE END IF IF( IPACKG.EQ.5 ) THEN IPACKG = IPACK ELSE IPACKG = 0 END IF END IF END IF END IF * ELSE * * 4) Generate Banded Matrix by first * Rotating by random Unitary matrices, * then reducing the bandwidth using Householder * transformations. * * Note: we should get here only if LDA .ge. N * IF( ISYM.EQ.1 ) THEN * * Non-symmetric -- A = U D V * CALL SLAGGE( MR, NC, LLB, UUB, D, A, LDA, ISEED, WORK, $ IINFO ) ELSE * * Symmetric -- A = U D U' * CALL SLAGSY( M, LLB, D, A, LDA, ISEED, WORK, IINFO ) * END IF IF( IINFO.NE.0 ) THEN INFO = 3 RETURN END IF END IF * * 5) Pack the matrix * IF( IPACK.NE.IPACKG ) THEN IF( IPACK.EQ.1 ) THEN * * 'U' -- Upper triangular, not packed * DO 300 J = 1, M DO 290 I = J + 1, M A( I, J ) = ZERO 290 CONTINUE 300 CONTINUE * ELSE IF( IPACK.EQ.2 ) THEN * * 'L' -- Lower triangular, not packed * DO 320 J = 2, M DO 310 I = 1, J - 1 A( I, J ) = ZERO 310 CONTINUE 320 CONTINUE * ELSE IF( IPACK.EQ.3 ) THEN * * 'C' -- Upper triangle packed Columnwise. * ICOL = 1 IROW = 0 DO 340 J = 1, M DO 330 I = 1, J IROW = IROW + 1 IF( IROW.GT.LDA ) THEN IROW = 1 ICOL = ICOL + 1 END IF A( IROW, ICOL ) = A( I, J ) 330 CONTINUE 340 CONTINUE * ELSE IF( IPACK.EQ.4 ) THEN * * 'R' -- Lower triangle packed Columnwise. * ICOL = 1 IROW = 0 DO 360 J = 1, M DO 350 I = J, M IROW = IROW + 1 IF( IROW.GT.LDA ) THEN IROW = 1 ICOL = ICOL + 1 END IF A( IROW, ICOL ) = A( I, J ) 350 CONTINUE 360 CONTINUE * ELSE IF( IPACK.GE.5 ) THEN * * 'B' -- The lower triangle is packed as a band matrix. * 'Q' -- The upper triangle is packed as a band matrix. * 'Z' -- The whole matrix is packed as a band matrix. * IF( IPACK.EQ.5 ) $ UUB = 0 IF( IPACK.EQ.6 ) $ LLB = 0 * DO 380 J = 1, UUB DO 370 I = MIN( J+LLB, M ), 1, -1 A( I-J+UUB+1, J ) = A( I, J ) 370 CONTINUE 380 CONTINUE * DO 400 J = UUB + 2, N DO 390 I = J - UUB, MIN( J+LLB, M ) A( I-J+UUB+1, J ) = A( I, J ) 390 CONTINUE 400 CONTINUE END IF * * If packed, zero out extraneous elements. * * Symmetric/Triangular Packed -- * zero out everything after A(IROW,ICOL) * IF( IPACK.EQ.3 .OR. IPACK.EQ.4 ) THEN DO 420 JC = ICOL, M DO 410 JR = IROW + 1, LDA A( JR, JC ) = ZERO 410 CONTINUE IROW = 0 420 CONTINUE * ELSE IF( IPACK.GE.5 ) THEN * * Packed Band -- * 1st row is now in A( UUB+2-j, j), zero above it * m-th row is now in A( M+UUB-j,j), zero below it * last non-zero diagonal is now in A( UUB+LLB+1,j ), * zero below it, too. * IR1 = UUB + LLB + 2 IR2 = UUB + M + 2 DO 450 JC = 1, N DO 430 JR = 1, UUB + 1 - JC A( JR, JC ) = ZERO 430 CONTINUE DO 440 JR = MAX( 1, MIN( IR1, IR2-JC ) ), LDA A( JR, JC ) = ZERO 440 CONTINUE 450 CONTINUE END IF END IF * RETURN * * End of SLATMS * END SHAR_EOF fi # end of overwriting check if test -f 'zlagge.f' then echo shar: will not over-write existing file "'zlagge.f'" else cat << SHAR_EOF > 'zlagge.f' SUBROUTINE ZLAGGE( M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO ) * * -- LAPACK auxiliary test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDA, M, N * .. * .. Array Arguments .. INTEGER ISEED( 4 ) DOUBLE PRECISION D( * ) COMPLEX*16 A( LDA, * ), WORK( * ) * .. * * Purpose * ======= * * ZLAGGE generates a complex general m by n matrix A, by pre- and post- * multiplying a real diagonal matrix D with random unitary matrices: * A = U*D*V. The lower and upper bandwidths may then be reduced to * kl and ku by additional unitary transformations. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * * KL (input) INTEGER * The number of nonzero subdiagonals within the band of A. * 0 <= KL <= M-1. * * KU (input) INTEGER * The number of nonzero superdiagonals within the band of A. * 0 <= KU <= N-1. * * D (input) DOUBLE PRECISION array, dimension (min(M,N)) * The diagonal elements of the diagonal matrix D. * * A (output) COMPLEX*16 array, dimension (LDA,N) * The generated m by n matrix A. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= M. * * ISEED (input/output) INTEGER array, dimension (4) * On entry, the seed of the random number generator; the array * elements must be between 0 and 4095, and ISEED(4) must be * odd. * On exit, the seed is updated. * * WORK (workspace) COMPLEX*16 array, dimension (M+N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), $ ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I, J DOUBLE PRECISION WN COMPLEX*16 TAU, WA, WB * .. * .. External Subroutines .. EXTERNAL XERBLA, ZGEMV, ZGERC, ZLACGV, ZLARNV, ZSCAL * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, MIN * .. * .. External Functions .. DOUBLE PRECISION DZNRM2 EXTERNAL DZNRM2 * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( KL.LT.0 .OR. KL.GT.M-1 ) THEN INFO = -3 ELSE IF( KU.LT.0 .OR. KU.GT.N-1 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -7 END IF IF( INFO.LT.0 ) THEN CALL XERBLA( 'ZLAGGE', -INFO ) RETURN END IF * * initialize A to diagonal matrix * DO 20 J = 1, N DO 10 I = 1, M A( I, J ) = ZERO 10 CONTINUE 20 CONTINUE DO 30 I = 1, MIN( M, N ) A( I, I ) = D( I ) 30 CONTINUE * * pre- and post-multiply A by random unitary matrices * DO 40 I = MIN( M, N ), 1, -1 IF( I.LT.M ) THEN * * generate random reflection * CALL ZLARNV( 3, ISEED, M-I+1, WORK ) WN = DZNRM2( M-I+1, WORK, 1 ) WA = ( WN / ABS( WORK( 1 ) ) )*WORK( 1 ) IF( WN.EQ.ZERO ) THEN TAU = ZERO ELSE WB = WORK( 1 ) + WA CALL ZSCAL( M-I, ONE / WB, WORK( 2 ), 1 ) WORK( 1 ) = ONE TAU = DBLE( WB / WA ) END IF * * multiply A(i:m,i:n) by random reflection from the left * CALL ZGEMV( 'Conjugate transpose', M-I+1, N-I+1, ONE, $ A( I, I ), LDA, WORK, 1, ZERO, WORK( M+1 ), 1 ) CALL ZGERC( M-I+1, N-I+1, -TAU, WORK, 1, WORK( M+1 ), 1, $ A( I, I ), LDA ) END IF IF( I.LT.N ) THEN * * generate random reflection * CALL ZLARNV( 3, ISEED, N-I+1, WORK ) WN = DZNRM2( N-I+1, WORK, 1 ) WA = ( WN / ABS( WORK( 1 ) ) )*WORK( 1 ) IF( WN.EQ.ZERO ) THEN TAU = ZERO ELSE WB = WORK( 1 ) + WA CALL ZSCAL( N-I, ONE / WB, WORK( 2 ), 1 ) WORK( 1 ) = ONE TAU = DBLE( WB / WA ) END IF * * multiply A(i:m,i:n) by random reflection from the right * CALL ZGEMV( 'No transpose', M-I+1, N-I+1, ONE, A( I, I ), $ LDA, WORK, 1, ZERO, WORK( N+1 ), 1 ) CALL ZGERC( M-I+1, N-I+1, -TAU, WORK( N+1 ), 1, WORK, 1, $ A( I, I ), LDA ) END IF 40 CONTINUE * * Reduce number of subdiagonals to KL and number of superdiagonals * to KU * DO 70 I = 1, MAX( M-1-KL, N-1-KU ) IF( KL.LE.KU ) THEN * * annihilate subdiagonal elements first (necessary if KL = 0) * IF( I.LE.MIN( M-1-KL, N ) ) THEN * * generate reflection to annihilate A(kl+i+1:m,i) * WN = DZNRM2( M-KL-I+1, A( KL+I, I ), 1 ) WA = ( WN / ABS( A( KL+I, I ) ) )*A( KL+I, I ) IF( WN.EQ.ZERO ) THEN TAU = ZERO ELSE WB = A( KL+I, I ) + WA CALL ZSCAL( M-KL-I, ONE / WB, A( KL+I+1, I ), 1 ) A( KL+I, I ) = ONE TAU = DBLE( WB / WA ) END IF * * apply reflection to A(kl+i:m,i+1:n) from the left * CALL ZGEMV( 'Conjugate transpose', M-KL-I+1, N-I, ONE, $ A( KL+I, I+1 ), LDA, A( KL+I, I ), 1, ZERO, $ WORK, 1 ) CALL ZGERC( M-KL-I+1, N-I, -TAU, A( KL+I, I ), 1, WORK, $ 1, A( KL+I, I+1 ), LDA ) A( KL+I, I ) = -WA END IF * IF( I.LE.MIN( N-1-KU, M ) ) THEN * * generate reflection to annihilate A(i,ku+i+1:n) * WN = DZNRM2( N-KU-I+1, A( I, KU+I ), LDA ) WA = ( WN / ABS( A( I, KU+I ) ) )*A( I, KU+I ) IF( WN.EQ.ZERO ) THEN TAU = ZERO ELSE WB = A( I, KU+I ) + WA CALL ZSCAL( N-KU-I, ONE / WB, A( I, KU+I+1 ), LDA ) A( I, KU+I ) = ONE TAU = DBLE( WB / WA ) END IF * * apply reflection to A(i+1:m,ku+i:n) from the right * CALL ZLACGV( N-KU-I+1, A( I, KU+I ), LDA ) CALL ZGEMV( 'No transpose', M-I, N-KU-I+1, ONE, $ A( I+1, KU+I ), LDA, A( I, KU+I ), LDA, ZERO, $ WORK, 1 ) CALL ZGERC( M-I, N-KU-I+1, -TAU, WORK, 1, A( I, KU+I ), $ LDA, A( I+1, KU+I ), LDA ) A( I, KU+I ) = -WA END IF ELSE * * annihilate superdiagonal elements first (necessary if * KU = 0) * IF( I.LE.MIN( N-1-KU, M ) ) THEN * * generate reflection to annihilate A(i,ku+i+1:n) * WN = DZNRM2( N-KU-I+1, A( I, KU+I ), LDA ) WA = ( WN / ABS( A( I, KU+I ) ) )*A( I, KU+I ) IF( WN.EQ.ZERO ) THEN TAU = ZERO ELSE WB = A( I, KU+I ) + WA CALL ZSCAL( N-KU-I, ONE / WB, A( I, KU+I+1 ), LDA ) A( I, KU+I ) = ONE TAU = DBLE( WB / WA ) END IF * * apply reflection to A(i+1:m,ku+i:n) from the right * CALL ZLACGV( N-KU-I+1, A( I, KU+I ), LDA ) CALL ZGEMV( 'No transpose', M-I, N-KU-I+1, ONE, $ A( I+1, KU+I ), LDA, A( I, KU+I ), LDA, ZERO, $ WORK, 1 ) CALL ZGERC( M-I, N-KU-I+1, -TAU, WORK, 1, A( I, KU+I ), $ LDA, A( I+1, KU+I ), LDA ) A( I, KU+I ) = -WA END IF * IF( I.LE.MIN( M-1-KL, N ) ) THEN * * generate reflection to annihilate A(kl+i+1:m,i) * WN = DZNRM2( M-KL-I+1, A( KL+I, I ), 1 ) WA = ( WN / ABS( A( KL+I, I ) ) )*A( KL+I, I ) IF( WN.EQ.ZERO ) THEN TAU = ZERO ELSE WB = A( KL+I, I ) + WA CALL ZSCAL( M-KL-I, ONE / WB, A( KL+I+1, I ), 1 ) A( KL+I, I ) = ONE TAU = DBLE( WB / WA ) END IF * * apply reflection to A(kl+i:m,i+1:n) from the left * CALL ZGEMV( 'Conjugate transpose', M-KL-I+1, N-I, ONE, $ A( KL+I, I+1 ), LDA, A( KL+I, I ), 1, ZERO, $ WORK, 1 ) CALL ZGERC( M-KL-I+1, N-I, -TAU, A( KL+I, I ), 1, WORK, $ 1, A( KL+I, I+1 ), LDA ) A( KL+I, I ) = -WA END IF END IF * DO 50 J = KL + I + 1, M A( J, I ) = ZERO 50 CONTINUE * DO 60 J = KU + I + 1, N A( I, J ) = ZERO 60 CONTINUE 70 CONTINUE RETURN * * End of ZLAGGE * END SHAR_EOF fi # end of overwriting check if test -f 'zlaghe.f' then echo shar: will not over-write existing file "'zlaghe.f'" else cat << SHAR_EOF > 'zlaghe.f' SUBROUTINE ZLAGHE( N, K, D, A, LDA, ISEED, WORK, INFO ) * * -- LAPACK auxiliary test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, N * .. * .. Array Arguments .. INTEGER ISEED( 4 ) DOUBLE PRECISION D( * ) COMPLEX*16 A( LDA, * ), WORK( * ) * .. * * Purpose * ======= * * ZLAGHE generates a complex hermitian matrix A, by pre- and post- * multiplying a real diagonal matrix D with a random unitary matrix: * A = U*D*U'. The semi-bandwidth may then be reduced to k by additional * unitary transformations. * * Arguments * ========= * * N (input) INTEGER * The order of the matrix A. N >= 0. * * K (input) INTEGER * The number of nonzero subdiagonals within the band of A. * 0 <= K <= N-1. * * D (input) DOUBLE PRECISION array, dimension (N) * The diagonal elements of the diagonal matrix D. * * A (output) COMPLEX*16 array, dimension (LDA,N) * The generated n by n hermitian matrix A (the full matrix is * stored). * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= N. * * ISEED (input/output) INTEGER array, dimension (4) * On entry, the seed of the random number generator; the array * elements must be between 0 and 4095, and ISEED(4) must be * odd. * On exit, the seed is updated. * * WORK (workspace) COMPLEX*16 array, dimension (2*N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. COMPLEX*16 ZERO, ONE, HALF PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), $ ONE = ( 1.0D+0, 0.0D+0 ), $ HALF = ( 0.5D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I, J DOUBLE PRECISION WN COMPLEX*16 ALPHA, TAU, WA, WB * .. * .. External Subroutines .. EXTERNAL XERBLA, ZAXPY, ZGEMV, ZGERC, ZHEMV, ZHER2, $ ZLARNV, ZSCAL * .. * .. External Functions .. DOUBLE PRECISION DZNRM2 COMPLEX*16 ZDOTC EXTERNAL DZNRM2, ZDOTC * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCONJG, MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 ELSE IF( K.LT.0 .OR. K.GT.N-1 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 END IF IF( INFO.LT.0 ) THEN CALL XERBLA( 'ZLAGHE', -INFO ) RETURN END IF * * initialize lower triangle of A to diagonal matrix * DO 20 J = 1, N DO 10 I = J + 1, N A( I, J ) = ZERO 10 CONTINUE 20 CONTINUE DO 30 I = 1, N A( I, I ) = D( I ) 30 CONTINUE * * Generate lower triangle of hermitian matrix * DO 40 I = N - 1, 1, -1 * * generate random reflection * CALL ZLARNV( 3, ISEED, N-I+1, WORK ) WN = DZNRM2( N-I+1, WORK, 1 ) WA = ( WN / ABS( WORK( 1 ) ) )*WORK( 1 ) IF( WN.EQ.ZERO ) THEN TAU = ZERO ELSE WB = WORK( 1 ) + WA CALL ZSCAL( N-I, ONE / WB, WORK( 2 ), 1 ) WORK( 1 ) = ONE TAU = DBLE( WB / WA ) END IF * * apply random reflection to A(i:n,i:n) from the left * and the right * * compute y := tau * A * u * CALL ZHEMV( 'Lower', N-I+1, TAU, A( I, I ), LDA, WORK, 1, ZERO, $ WORK( N+1 ), 1 ) * * compute v := y - 1/2 * tau * ( y, u ) * u * ALPHA = -HALF*TAU*ZDOTC( N-I+1, WORK( N+1 ), 1, WORK, 1 ) CALL ZAXPY( N-I+1, ALPHA, WORK, 1, WORK( N+1 ), 1 ) * * apply the transformation as a rank-2 update to A(i:n,i:n) * CALL ZHER2( 'Lower', N-I+1, -ONE, WORK, 1, WORK( N+1 ), 1, $ A( I, I ), LDA ) 40 CONTINUE * * Reduce number of subdiagonals to K * DO 60 I = 1, N - 1 - K * * generate reflection to annihilate A(k+i+1:n,i) * WN = DZNRM2( N-K-I+1, A( K+I, I ), 1 ) WA = ( WN / ABS( A( K+I, I ) ) )*A( K+I, I ) IF( WN.EQ.ZERO ) THEN TAU = ZERO ELSE WB = A( K+I, I ) + WA CALL ZSCAL( N-K-I, ONE / WB, A( K+I+1, I ), 1 ) A( K+I, I ) = ONE TAU = DBLE( WB / WA ) END IF * * apply reflection to A(k+i:n,i+1:k+i-1) from the left * CALL ZGEMV( 'Conjugate transpose', N-K-I+1, K-1, ONE, $ A( K+I, I+1 ), LDA, A( K+I, I ), 1, ZERO, WORK, 1 ) CALL ZGERC( N-K-I+1, K-1, -TAU, A( K+I, I ), 1, WORK, 1, $ A( K+I, I+1 ), LDA ) * * apply reflection to A(k+i:n,k+i:n) from the left and the right * * compute y := tau * A * u * CALL ZHEMV( 'Lower', N-K-I+1, TAU, A( K+I, K+I ), LDA, $ A( K+I, I ), 1, ZERO, WORK, 1 ) * * compute v := y - 1/2 * tau * ( y, u ) * u * ALPHA = -HALF*TAU*ZDOTC( N-K-I+1, WORK, 1, A( K+I, I ), 1 ) CALL ZAXPY( N-K-I+1, ALPHA, A( K+I, I ), 1, WORK, 1 ) * * apply hermitian rank-2 update to A(k+i:n,k+i:n) * CALL ZHER2( 'Lower', N-K-I+1, -ONE, A( K+I, I ), 1, WORK, 1, $ A( K+I, K+I ), LDA ) * A( K+I, I ) = -WA DO 50 J = K + I + 1, N A( J, I ) = ZERO 50 CONTINUE 60 CONTINUE * * Store full hermitian matrix * DO 80 J = 1, N DO 70 I = J + 1, N A( J, I ) = DCONJG( A( I, J ) ) 70 CONTINUE 80 CONTINUE RETURN * * End of ZLAGHE * END SHAR_EOF fi # end of overwriting check if test -f 'zlagsy.f' then echo shar: will not over-write existing file "'zlagsy.f'" else cat << SHAR_EOF > 'zlagsy.f' SUBROUTINE ZLAGSY( N, K, D, A, LDA, ISEED, WORK, INFO ) * * -- LAPACK auxiliary test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, N * .. * .. Array Arguments .. INTEGER ISEED( 4 ) DOUBLE PRECISION D( * ) COMPLEX*16 A( LDA, * ), WORK( * ) * .. * * Purpose * ======= * * ZLAGSY generates a complex symmetric matrix A, by pre- and post- * multiplying a real diagonal matrix D with a random unitary matrix: * A = U*D*U**T. The semi-bandwidth may then be reduced to k by * additional unitary transformations. * * Arguments * ========= * * N (input) INTEGER * The order of the matrix A. N >= 0. * * K (input) INTEGER * The number of nonzero subdiagonals within the band of A. * 0 <= K <= N-1. * * D (input) DOUBLE PRECISION array, dimension (N) * The diagonal elements of the diagonal matrix D. * * A (output) COMPLEX*16 array, dimension (LDA,N) * The generated n by n symmetric matrix A (the full matrix is * stored). * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= N. * * ISEED (input/output) INTEGER array, dimension (4) * On entry, the seed of the random number generator; the array * elements must be between 0 and 4095, and ISEED(4) must be * odd. * On exit, the seed is updated. * * WORK (workspace) COMPLEX*16 array, dimension (2*N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. COMPLEX*16 ZERO, ONE, HALF PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), $ ONE = ( 1.0D+0, 0.0D+0 ), $ HALF = ( 0.5D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I, II, J, JJ DOUBLE PRECISION WN COMPLEX*16 ALPHA, TAU, WA, WB * .. * .. External Subroutines .. EXTERNAL XERBLA, ZAXPY, ZGEMV, ZGERC, ZLACGV, ZLARNV, $ ZSCAL, ZSYMV * .. * .. External Functions .. DOUBLE PRECISION DZNRM2 COMPLEX*16 ZDOTC EXTERNAL DZNRM2, ZDOTC * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 ELSE IF( K.LT.0 .OR. K.GT.N-1 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 END IF IF( INFO.LT.0 ) THEN CALL XERBLA( 'ZLAGSY', -INFO ) RETURN END IF * * initialize lower triangle of A to diagonal matrix * DO 20 J = 1, N DO 10 I = J + 1, N A( I, J ) = ZERO 10 CONTINUE 20 CONTINUE DO 30 I = 1, N A( I, I ) = D( I ) 30 CONTINUE * * Generate lower triangle of symmetric matrix * DO 60 I = N - 1, 1, -1 * * generate random reflection * CALL ZLARNV( 3, ISEED, N-I+1, WORK ) WN = DZNRM2( N-I+1, WORK, 1 ) WA = ( WN / ABS( WORK( 1 ) ) )*WORK( 1 ) IF( WN.EQ.ZERO ) THEN TAU = ZERO ELSE WB = WORK( 1 ) + WA CALL ZSCAL( N-I, ONE / WB, WORK( 2 ), 1 ) WORK( 1 ) = ONE TAU = DBLE( WB / WA ) END IF * * apply random reflection to A(i:n,i:n) from the left * and the right * * compute y := tau * A * conjg(u) * CALL ZLACGV( N-I+1, WORK, 1 ) CALL ZSYMV( 'Lower', N-I+1, TAU, A( I, I ), LDA, WORK, 1, ZERO, $ WORK( N+1 ), 1 ) CALL ZLACGV( N-I+1, WORK, 1 ) * * compute v := y - 1/2 * tau * ( u, y ) * u * ALPHA = -HALF*TAU*ZDOTC( N-I+1, WORK, 1, WORK( N+1 ), 1 ) CALL ZAXPY( N-I+1, ALPHA, WORK, 1, WORK( N+1 ), 1 ) * * apply the transformation as a rank-2 update to A(i:n,i:n) * * CALL ZSYR2( 'Lower', N-I+1, -ONE, WORK, 1, WORK( N+1 ), 1, * $ A( I, I ), LDA ) * DO 50 JJ = I, N DO 40 II = JJ, N A( II, JJ ) = A( II, JJ ) - $ WORK( II-I+1 )*WORK( N+JJ-I+1 ) - $ WORK( N+II-I+1 )*WORK( JJ-I+1 ) 40 CONTINUE 50 CONTINUE 60 CONTINUE * * Reduce number of subdiagonals to K * DO 100 I = 1, N - 1 - K * * generate reflection to annihilate A(k+i+1:n,i) * WN = DZNRM2( N-K-I+1, A( K+I, I ), 1 ) WA = ( WN / ABS( A( K+I, I ) ) )*A( K+I, I ) IF( WN.EQ.ZERO ) THEN TAU = ZERO ELSE WB = A( K+I, I ) + WA CALL ZSCAL( N-K-I, ONE / WB, A( K+I+1, I ), 1 ) A( K+I, I ) = ONE TAU = DBLE( WB / WA ) END IF * * apply reflection to A(k+i:n,i+1:k+i-1) from the left * CALL ZGEMV( 'Conjugate transpose', N-K-I+1, K-1, ONE, $ A( K+I, I+1 ), LDA, A( K+I, I ), 1, ZERO, WORK, 1 ) CALL ZGERC( N-K-I+1, K-1, -TAU, A( K+I, I ), 1, WORK, 1, $ A( K+I, I+1 ), LDA ) * * apply reflection to A(k+i:n,k+i:n) from the left and the right * * compute y := tau * A * conjg(u) * CALL ZLACGV( N-K-I+1, A( K+I, I ), 1 ) CALL ZSYMV( 'Lower', N-K-I+1, TAU, A( K+I, K+I ), LDA, $ A( K+I, I ), 1, ZERO, WORK, 1 ) CALL ZLACGV( N-K-I+1, A( K+I, I ), 1 ) * * compute v := y - 1/2 * tau * ( u, y ) * u * ALPHA = -HALF*TAU*ZDOTC( N-K-I+1, A( K+I, I ), 1, WORK, 1 ) CALL ZAXPY( N-K-I+1, ALPHA, A( K+I, I ), 1, WORK, 1 ) * * apply symmetric rank-2 update to A(k+i:n,k+i:n) * * CALL ZSYR2( 'Lower', N-K-I+1, -ONE, A( K+I, I ), 1, WORK, 1, * $ A( K+I, K+I ), LDA ) * DO 80 JJ = K + I, N DO 70 II = JJ, N A( II, JJ ) = A( II, JJ ) - A( II, I )*WORK( JJ-K-I+1 ) - $ WORK( II-K-I+1 )*A( JJ, I ) 70 CONTINUE 80 CONTINUE * A( K+I, I ) = -WA DO 90 J = K + I + 1, N A( J, I ) = ZERO 90 CONTINUE 100 CONTINUE * * Store full symmetric matrix * DO 120 J = 1, N DO 110 I = J + 1, N A( J, I ) = A( I, J ) 110 CONTINUE 120 CONTINUE RETURN * * End of ZLAGSY * END SHAR_EOF fi # end of overwriting check if test -f 'zlarge.f' then echo shar: will not over-write existing file "'zlarge.f'" else cat << SHAR_EOF > 'zlarge.f' SUBROUTINE ZLARGE( N, A, LDA, ISEED, WORK, INFO ) * * -- LAPACK auxiliary test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. INTEGER INFO, LDA, N * .. * .. Array Arguments .. INTEGER ISEED( 4 ) COMPLEX*16 A( LDA, * ), WORK( * ) * .. * * Purpose * ======= * * ZLARGE pre- and post-multiplies a complex general n by n matrix A * with a random unitary matrix: A = U*D*U'. * * Arguments * ========= * * N (input) INTEGER * The order of the matrix A. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the original n by n matrix A. * On exit, A is overwritten by U*A*U' for some random * unitary matrix U. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= N. * * ISEED (input/output) INTEGER array, dimension (4) * On entry, the seed of the random number generator; the array * elements must be between 0 and 4095, and ISEED(4) must be * odd. * On exit, the seed is updated. * * WORK (workspace) COMPLEX*16 array, dimension (2*N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), $ ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I DOUBLE PRECISION WN COMPLEX*16 TAU, WA, WB * .. * .. External Subroutines .. EXTERNAL XERBLA, ZGEMV, ZGERC, ZLARNV, ZSCAL * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX * .. * .. External Functions .. DOUBLE PRECISION DZNRM2 EXTERNAL DZNRM2 * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -3 END IF IF( INFO.LT.0 ) THEN CALL XERBLA( 'ZLARGE', -INFO ) RETURN END IF * * pre- and post-multiply A by random unitary matrix * DO 10 I = N, 1, -1 * * generate random reflection * CALL ZLARNV( 3, ISEED, N-I+1, WORK ) WN = DZNRM2( N-I+1, WORK, 1 ) WA = ( WN / ABS( WORK( 1 ) ) )*WORK( 1 ) IF( WN.EQ.ZERO ) THEN TAU = ZERO ELSE WB = WORK( 1 ) + WA CALL ZSCAL( N-I, ONE / WB, WORK( 2 ), 1 ) WORK( 1 ) = ONE TAU = DBLE( WB / WA ) END IF * * multiply A(i:n,1:n) by random reflection from the left * CALL ZGEMV( 'Conjugate transpose', N-I+1, N, ONE, A( I, 1 ), $ LDA, WORK, 1, ZERO, WORK( N+1 ), 1 ) CALL ZGERC( N-I+1, N, -TAU, WORK, 1, WORK( N+1 ), 1, A( I, 1 ), $ LDA ) * * multiply A(1:n,i:n) by random reflection from the right * CALL ZGEMV( 'No transpose', N, N-I+1, ONE, A( 1, I ), LDA, $ WORK, 1, ZERO, WORK( N+1 ), 1 ) CALL ZGERC( N, N-I+1, -TAU, WORK( N+1 ), 1, WORK, 1, A( 1, I ), $ LDA ) 10 CONTINUE RETURN * * End of ZLARGE * END SHAR_EOF fi # end of overwriting check if test -f 'zlarnd.f' then echo shar: will not over-write existing file "'zlarnd.f'" else cat << SHAR_EOF > 'zlarnd.f' DOUBLE COMPLEX FUNCTION ZLARND( IDIST, ISEED ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. INTEGER IDIST * .. * .. Array Arguments .. INTEGER ISEED( 4 ) * .. * * Purpose * ======= * * ZLARND returns a random complex number from a uniform or normal * distribution. * * Arguments * ========= * * IDIST (input) INTEGER * Specifies the distribution of the random numbers: * = 1: real and imaginary parts each uniform (0,1) * = 2: real and imaginary parts each uniform (-1,1) * = 3: real and imaginary parts each normal (0,1) * = 4: uniformly distributed on the disc abs(z) <= 1 * = 5: uniformly distributed on the circle abs(z) = 1 * * ISEED (input/output) INTEGER array, dimension (4) * On entry, the seed of the random number generator; the array * elements must be between 0 and 4095, and ISEED(4) must be * odd. * On exit, the seed is updated. * * Further Details * =============== * * This routine calls the auxiliary routine DLARAN to generate a random * real number from a uniform (0,1) distribution. The Box-Muller method * is used to transform numbers from a uniform to a normal distribution. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) DOUBLE PRECISION TWOPI PARAMETER ( TWOPI = 6.2831853071795864769252867663D+0 ) * .. * .. Local Scalars .. DOUBLE PRECISION T1, T2 * .. * .. External Functions .. DOUBLE PRECISION DLARAN EXTERNAL DLARAN * .. * .. Intrinsic Functions .. INTRINSIC DCMPLX, EXP, LOG, SQRT * .. * .. Executable Statements .. * * Generate a pair of real random numbers from a uniform (0,1) * distribution * T1 = DLARAN( ISEED ) T2 = DLARAN( ISEED ) * IF( IDIST.EQ.1 ) THEN * * real and imaginary parts each uniform (0,1) * ZLARND = DCMPLX( T1, T2 ) ELSE IF( IDIST.EQ.2 ) THEN * * real and imaginary parts each uniform (-1,1) * ZLARND = DCMPLX( TWO*T1-ONE, TWO*T2-ONE ) ELSE IF( IDIST.EQ.3 ) THEN * * real and imaginary parts each normal (0,1) * ZLARND = SQRT( -TWO*LOG( T1 ) )*EXP( DCMPLX( ZERO, TWOPI*T2 ) ) ELSE IF( IDIST.EQ.4 ) THEN * * uniform distribution on the unit disc abs(z) <= 1 * ZLARND = SQRT( T1 )*EXP( DCMPLX( ZERO, TWOPI*T2 ) ) ELSE IF( IDIST.EQ.5 ) THEN * * uniform distribution on the unit circle abs(z) = 1 * ZLARND = EXP( DCMPLX( ZERO, TWOPI*T2 ) ) END IF RETURN * * End of ZLARND * END SHAR_EOF fi # end of overwriting check if test -f 'zlaror.f' then echo shar: will not over-write existing file "'zlaror.f'" else cat << SHAR_EOF > 'zlaror.f' SUBROUTINE ZLAROR( SIDE, INIT, M, N, A, LDA, ISEED, X, INFO ) * * -- LAPACK auxiliary test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER INIT, SIDE INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. INTEGER ISEED( 4 ) COMPLEX*16 A( LDA, * ), X( * ) * .. * * Purpose * ======= * * ZLAROR pre- or post-multiplies an M by N matrix A by a random * unitary matrix U, overwriting A. A may optionally be * initialized to the identity matrix before multiplying by U. * U is generated using the method of G.W. Stewart * ( SIAM J. Numer. Anal. 17, 1980, pp. 403-409 ). * (BLAS-2 version) * * Arguments * ========= * * SIDE - CHARACTER*1 * SIDE specifies whether A is multiplied on the left or right * by U. * SIDE = 'L' Multiply A on the left (premultiply) by U * SIDE = 'R' Multiply A on the right (postmultiply) by U* * SIDE = 'C' Multiply A on the left by U and the right by U* * SIDE = 'T' Multiply A on the left by U and the right by U' * Not modified. * * INIT - CHARACTER*1 * INIT specifies whether or not A should be initialized to * the identity matrix. * INIT = 'I' Initialize A to (a section of) the * identity matrix before applying U. * INIT = 'N' No initialization. Apply U to the * input matrix A. * * INIT = 'I' may be used to generate square (i.e., unitary) * or rectangular orthogonal matrices (orthogonality being * in the sense of ZDOTC): * * For square matrices, M=N, and SIDE many be either 'L' or * 'R'; the rows will be orthogonal to each other, as will the * columns. * For rectangular matrices where M < N, SIDE = 'R' will * produce a dense matrix whose rows will be orthogonal and * whose columns will not, while SIDE = 'L' will produce a * matrix whose rows will be orthogonal, and whose first M * columns will be orthogonal, the remaining columns being * zero. * For matrices where M > N, just use the previous * explaination, interchanging 'L' and 'R' and "rows" and * "columns". * * Not modified. * * M - INTEGER * Number of rows of A. Not modified. * * N - INTEGER * Number of columns of A. Not modified. * * A - COMPLEX*16 array, dimension ( LDA, N ) * Input and output array. Overwritten by U A ( if SIDE = 'L' ) * or by A U ( if SIDE = 'R' ) * or by U A U* ( if SIDE = 'C') * or by U A U' ( if SIDE = 'T') on exit. * * LDA - INTEGER * Leading dimension of A. Must be at least MAX ( 1, M ). * Not modified. * * ISEED - INTEGER array, dimension ( 4 ) * On entry ISEED specifies the seed of the random number * generator. The array elements should be between 0 and 4095; * if not they will be reduced mod 4096. Also, ISEED(4) must * be odd. The random number generator uses a linear * congruential sequence limited to small integers, and so * should produce machine independent random numbers. The * values of ISEED are changed on exit, and can be used in the * next call to ZLAROR to continue the same random number * sequence. * Modified. * * X - COMPLEX*16 array, dimension ( 3*MAX( M, N ) ) * Workspace. Of length: * 2*M + N if SIDE = 'L', * 2*N + M if SIDE = 'R', * 3*N if SIDE = 'C' or 'T'. * Modified. * * INFO - INTEGER * An error flag. It is set to: * 0 if no error. * 1 if ZLARND returned a bad random number (installation * problem) * -1 if SIDE is not L, R, C, or T. * -3 if M is negative. * -4 if N is negative or if SIDE is C or T and N is not equal * to M. * -6 if LDA is less than M. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, TOOSML PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, $ TOOSML = 1.0D-20 ) COMPLEX*16 CZERO, CONE PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), $ CONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER IROW, ITYPE, IXFRM, J, JCOL, KBEG, NXFRM DOUBLE PRECISION FACTOR, XABS, XNORM COMPLEX*16 CSIGN, XNORMS * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DZNRM2 COMPLEX*16 ZLARND EXTERNAL LSAME, DZNRM2, ZLARND * .. * .. External Subroutines .. EXTERNAL XERBLA, ZGEMV, ZGERC, ZLACGV, ZLASET, ZSCAL * .. * .. Intrinsic Functions .. INTRINSIC ABS, DCMPLX, DCONJG * .. * .. Executable Statements .. * IF( N.EQ.0 .OR. M.EQ.0 ) $ RETURN * ITYPE = 0 IF( LSAME( SIDE, 'L' ) ) THEN ITYPE = 1 ELSE IF( LSAME( SIDE, 'R' ) ) THEN ITYPE = 2 ELSE IF( LSAME( SIDE, 'C' ) ) THEN ITYPE = 3 ELSE IF( LSAME( SIDE, 'T' ) ) THEN ITYPE = 4 END IF * * Check for argument errors. * INFO = 0 IF( ITYPE.EQ.0 ) THEN INFO = -1 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.3 .AND. N.NE.M ) ) THEN INFO = -4 ELSE IF( LDA.LT.M ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZLAROR', -INFO ) RETURN END IF * IF( ITYPE.EQ.1 ) THEN NXFRM = M ELSE NXFRM = N END IF * * Initialize A to the identity matrix if desired * IF( LSAME( INIT, 'I' ) ) $ CALL ZLASET( 'Full', M, N, CZERO, CONE, A, LDA ) * * If no rotation possible, still multiply by * a random complex number from the circle |x| = 1 * * 2) Compute Rotation by computing Householder * Transformations H(2), H(3), ..., H(n). Note that the * order in which they are computed is irrelevant. * DO 10 J = 1, NXFRM X( J ) = CZERO 10 CONTINUE * DO 30 IXFRM = 2, NXFRM KBEG = NXFRM - IXFRM + 1 * * Generate independent normal( 0, 1 ) random numbers * DO 20 J = KBEG, NXFRM X( J ) = ZLARND( 3, ISEED ) 20 CONTINUE * * Generate a Householder transformation from the random vector X * XNORM = DZNRM2( IXFRM, X( KBEG ), 1 ) XABS = ABS( X( KBEG ) ) IF( XABS.NE.CZERO ) THEN CSIGN = X( KBEG ) / XABS ELSE CSIGN = CONE END IF XNORMS = CSIGN*XNORM X( NXFRM+KBEG ) = -CSIGN FACTOR = XNORM*( XNORM+XABS ) IF( ABS( FACTOR ).LT.TOOSML ) THEN INFO = 1 CALL XERBLA( 'ZLAROR', -INFO ) RETURN ELSE FACTOR = ONE / FACTOR END IF X( KBEG ) = X( KBEG ) + XNORMS * * Apply Householder transformation to A * IF( ITYPE.EQ.1 .OR. ITYPE.EQ.3 .OR. ITYPE.EQ.4 ) THEN * * Apply H(k) on the left of A * CALL ZGEMV( 'C', IXFRM, N, CONE, A( KBEG, 1 ), LDA, $ X( KBEG ), 1, CZERO, X( 2*NXFRM+1 ), 1 ) CALL ZGERC( IXFRM, N, -DCMPLX( FACTOR ), X( KBEG ), 1, $ X( 2*NXFRM+1 ), 1, A( KBEG, 1 ), LDA ) * END IF * IF( ITYPE.GE.2 .AND. ITYPE.LE.4 ) THEN * * Apply H(k)* (or H(k)') on the right of A * IF( ITYPE.EQ.4 ) THEN CALL ZLACGV( IXFRM, X( KBEG ), 1 ) END IF * CALL ZGEMV( 'N', M, IXFRM, CONE, A( 1, KBEG ), LDA, $ X( KBEG ), 1, CZERO, X( 2*NXFRM+1 ), 1 ) CALL ZGERC( M, IXFRM, -DCMPLX( FACTOR ), X( 2*NXFRM+1 ), 1, $ X( KBEG ), 1, A( 1, KBEG ), LDA ) * END IF 30 CONTINUE * X( 1 ) = ZLARND( 3, ISEED ) XABS = ABS( X( 1 ) ) IF( XABS.NE.ZERO ) THEN CSIGN = X( 1 ) / XABS ELSE CSIGN = CONE END IF X( 2*NXFRM ) = CSIGN * * Scale the matrix A by D. * IF( ITYPE.EQ.1 .OR. ITYPE.EQ.3 .OR. ITYPE.EQ.4 ) THEN DO 40 IROW = 1, M CALL ZSCAL( N, DCONJG( X( NXFRM+IROW ) ), A( IROW, 1 ), $ LDA ) 40 CONTINUE END IF * IF( ITYPE.EQ.2 .OR. ITYPE.EQ.3 ) THEN DO 50 JCOL = 1, N CALL ZSCAL( M, X( NXFRM+JCOL ), A( 1, JCOL ), 1 ) 50 CONTINUE END IF * IF( ITYPE.EQ.4 ) THEN DO 60 JCOL = 1, N CALL ZSCAL( M, DCONJG( X( NXFRM+JCOL ) ), A( 1, JCOL ), 1 ) 60 CONTINUE END IF RETURN * * End of ZLAROR * END SHAR_EOF fi # end of overwriting check if test -f 'zlarot.f' then echo shar: will not over-write existing file "'zlarot.f'" else cat << SHAR_EOF > 'zlarot.f' SUBROUTINE ZLAROT( LROWS, LLEFT, LRIGHT, NL, C, S, A, LDA, XLEFT, $ XRIGHT ) * * -- LAPACK auxiliary test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. LOGICAL LLEFT, LRIGHT, LROWS INTEGER LDA, NL COMPLEX*16 C, S, XLEFT, XRIGHT * .. * .. Array Arguments .. COMPLEX*16 A( * ) * .. * * Purpose * ======= * * ZLAROT applies a (Givens) rotation to two adjacent rows or * columns, where one element of the first and/or last column/row * may be a separate variable. This is specifically indended * for use on matrices stored in some format other than GE, so * that elements of the matrix may be used or modified for which * no array element is provided. * * One example is a symmetric matrix in SB format (bandwidth=4), for * which UPLO='L': Two adjacent rows will have the format: * * row j: * * * * * . . . . * row j+1: * * * * * . . . . * * '*' indicates elements for which storage is provided, * '.' indicates elements for which no storage is provided, but * are not necessarily zero; their values are determined by * symmetry. ' ' indicates elements which are necessarily zero, * and have no storage provided. * * Those columns which have two '*'s can be handled by DROT. * Those columns which have no '*'s can be ignored, since as long * as the Givens rotations are carefully applied to preserve * symmetry, their values are determined. * Those columns which have one '*' have to be handled separately, * by using separate variables "p" and "q": * * row j: * * * * * p . . . * row j+1: q * * * * * . . . . * * The element p would have to be set correctly, then that column * is rotated, setting p to its new value. The next call to * ZLAROT would rotate columns j and j+1, using p, and restore * symmetry. The element q would start out being zero, and be * made non-zero by the rotation. Later, rotations would presumably * be chosen to zero q out. * * Typical Calling Sequences: rotating the i-th and (i+1)-st rows. * ------- ------- --------- * * General dense matrix: * * CALL ZLAROT(.TRUE.,.FALSE.,.FALSE., N, C,S, * A(i,1),LDA, DUMMY, DUMMY) * * General banded matrix in GB format: * * j = MAX(1, i-KL ) * NL = MIN( N, i+KU+1 ) + 1-j * CALL ZLAROT( .TRUE., i-KL.GE.1, i+KU.LT.N, NL, C,S, * A(KU+i+1-j,j),LDA-1, XLEFT, XRIGHT ) * * [ note that i+1-j is just MIN(i,KL+1) ] * * Symmetric banded matrix in SY format, bandwidth K, * lower triangle only: * * j = MAX(1, i-K ) * NL = MIN( K+1, i ) + 1 * CALL ZLAROT( .TRUE., i-K.GE.1, .TRUE., NL, C,S, * A(i,j), LDA, XLEFT, XRIGHT ) * * Same, but upper triangle only: * * NL = MIN( K+1, N-i ) + 1 * CALL ZLAROT( .TRUE., .TRUE., i+K.LT.N, NL, C,S, * A(i,i), LDA, XLEFT, XRIGHT ) * * Symmetric banded matrix in SB format, bandwidth K, * lower triangle only: * * [ same as for SY, except:] * . . . . * A(i+1-j,j), LDA-1, XLEFT, XRIGHT ) * * [ note that i+1-j is just MIN(i,K+1) ] * * Same, but upper triangle only: * . . . * A(K+1,i), LDA-1, XLEFT, XRIGHT ) * * Rotating columns is just the transpose of rotating rows, except * for GB and SB: (rotating columns i and i+1) * * GB: * j = MAX(1, i-KU ) * NL = MIN( N, i+KL+1 ) + 1-j * CALL ZLAROT( .TRUE., i-KU.GE.1, i+KL.LT.N, NL, C,S, * A(KU+j+1-i,i),LDA-1, XTOP, XBOTTM ) * * [note that KU+j+1-i is just MAX(1,KU+2-i)] * * SB: (upper triangle) * * . . . . . . * A(K+j+1-i,i),LDA-1, XTOP, XBOTTM ) * * SB: (lower triangle) * * . . . . . . * A(1,i),LDA-1, XTOP, XBOTTM ) * * Arguments * ========= * * LROWS - LOGICAL * If .TRUE., then ZLAROT will rotate two rows. If .FALSE., * then it will rotate two columns. * Not modified. * * LLEFT - LOGICAL * If .TRUE., then XLEFT will be used instead of the * corresponding element of A for the first element in the * second row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) * If .FALSE., then the corresponding element of A will be * used. * Not modified. * * LRIGHT - LOGICAL * If .TRUE., then XRIGHT will be used instead of the * corresponding element of A for the last element in the * first row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) If * .FALSE., then the corresponding element of A will be used. * Not modified. * * NL - INTEGER * The length of the rows (if LROWS=.TRUE.) or columns (if * LROWS=.FALSE.) to be rotated. If XLEFT and/or XRIGHT are * used, the columns/rows they are in should be included in * NL, e.g., if LLEFT = LRIGHT = .TRUE., then NL must be at * least 2. The number of rows/columns to be rotated * exclusive of those involving XLEFT and/or XRIGHT may * not be negative, i.e., NL minus how many of LLEFT and * LRIGHT are .TRUE. must be at least zero; if not, XERBLA * will be called. * Not modified. * * C, S - COMPLEX*16 * Specify the Givens rotation to be applied. If LROWS is * true, then the matrix ( c s ) * ( _ _ ) * (-s c ) is applied from the left; * if false, then the transpose (not conjugated) thereof is * applied from the right. Note that in contrast to the * output of ZROTG or to most versions of ZROT, both C and S * are complex. For a Givens rotation, |C|**2 + |S|**2 should * be 1, but this is not checked. * Not modified. * * A - COMPLEX*16 array. * The array containing the rows/columns to be rotated. The * first element of A should be the upper left element to * be rotated. * Read and modified. * * LDA - INTEGER * The "effective" leading dimension of A. If A contains * a matrix stored in GE, HE, or SY format, then this is just * the leading dimension of A as dimensioned in the calling * routine. If A contains a matrix stored in band (GB, HB, or * SB) format, then this should be *one less* than the leading * dimension used in the calling routine. Thus, if A were * dimensioned A(LDA,*) in ZLAROT, then A(1,j) would be the * j-th element in the first of the two rows to be rotated, * and A(2,j) would be the j-th in the second, regardless of * how the array may be stored in the calling routine. [A * cannot, however, actually be dimensioned thus, since for * band format, the row number may exceed LDA, which is not * legal FORTRAN.] * If LROWS=.TRUE., then LDA must be at least 1, otherwise * it must be at least NL minus the number of .TRUE. values * in XLEFT and XRIGHT. * Not modified. * * XLEFT - COMPLEX*16 * If LLEFT is .TRUE., then XLEFT will be used and modified * instead of A(2,1) (if LROWS=.TRUE.) or A(1,2) * (if LROWS=.FALSE.). * Read and modified. * * XRIGHT - COMPLEX*16 * If LRIGHT is .TRUE., then XRIGHT will be used and modified * instead of A(1,NL) (if LROWS=.TRUE.) or A(NL,1) * (if LROWS=.FALSE.). * Read and modified. * * ===================================================================== * * .. Local Scalars .. INTEGER IINC, INEXT, IX, IY, IYT, J, NT COMPLEX*16 TEMPX * .. * .. Local Arrays .. COMPLEX*16 XT( 2 ), YT( 2 ) * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Intrinsic Functions .. INTRINSIC DCONJG * .. * .. Executable Statements .. * * Set up indices, arrays for ends * IF( LROWS ) THEN IINC = LDA INEXT = 1 ELSE IINC = 1 INEXT = LDA END IF * IF( LLEFT ) THEN NT = 1 IX = 1 + IINC IY = 2 + LDA XT( 1 ) = A( 1 ) YT( 1 ) = XLEFT ELSE NT = 0 IX = 1 IY = 1 + INEXT END IF * IF( LRIGHT ) THEN IYT = 1 + INEXT + ( NL-1 )*IINC NT = NT + 1 XT( NT ) = XRIGHT YT( NT ) = A( IYT ) END IF * * Check for errors * IF( NL.LT.NT ) THEN CALL XERBLA( 'ZLAROT', 4 ) RETURN END IF IF( LDA.LE.0 .OR. ( .NOT.LROWS .AND. LDA.LT.NL-NT ) ) THEN CALL XERBLA( 'ZLAROT', 8 ) RETURN END IF * * Rotate * * ZROT( NL-NT, A(IX),IINC, A(IY),IINC, C, S ) with complex C, S * DO 10 J = 0, NL - NT - 1 TEMPX = C*A( IX+J*IINC ) + S*A( IY+J*IINC ) A( IY+J*IINC ) = -DCONJG( S )*A( IX+J*IINC ) + $ DCONJG( C )*A( IY+J*IINC ) A( IX+J*IINC ) = TEMPX 10 CONTINUE * * ZROT( NT, XT,1, YT,1, C, S ) with complex C, S * DO 20 J = 1, NT TEMPX = C*XT( J ) + S*YT( J ) YT( J ) = -DCONJG( S )*XT( J ) + DCONJG( C )*YT( J ) XT( J ) = TEMPX 20 CONTINUE * * Stuff values back into XLEFT, XRIGHT, etc. * IF( LLEFT ) THEN A( 1 ) = XT( 1 ) XLEFT = YT( 1 ) END IF * IF( LRIGHT ) THEN XRIGHT = XT( NT ) A( IYT ) = YT( NT ) END IF * RETURN * * End of ZLAROT * END SHAR_EOF fi # end of overwriting check if test -f 'zlatm1.f' then echo shar: will not over-write existing file "'zlatm1.f'" else cat << SHAR_EOF > 'zlatm1.f' SUBROUTINE ZLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO ) * * -- LAPACK auxiliary test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. INTEGER IDIST, INFO, IRSIGN, MODE, N DOUBLE PRECISION COND * .. * .. Array Arguments .. INTEGER ISEED( 4 ) COMPLEX*16 D( * ) * .. * * Purpose * ======= * * ZLATM1 computes the entries of D(1..N) as specified by * MODE, COND and IRSIGN. IDIST and ISEED determine the generation * of random numbers. ZLATM1 is called by CLATMR to generate * random test matrices for LAPACK programs. * * Arguments * ========= * * MODE - INTEGER * On entry describes how D is to be computed: * MODE = 0 means do not change D. * MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND * MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND * MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) * MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) * MODE = 5 sets D to random numbers in the range * ( 1/COND , 1 ) such that their logarithms * are uniformly distributed. * MODE = 6 set D to random numbers from same distribution * as the rest of the matrix. * MODE < 0 has the same meaning as ABS(MODE), except that * the order of the elements of D is reversed. * Thus if MODE is positive, D has entries ranging from * 1 to 1/COND, if negative, from 1/COND to 1, * Not modified. * * COND - DOUBLE PRECISION * On entry, used as described under MODE above. * If used, it must be >= 1. Not modified. * * IRSIGN - INTEGER * On entry, if MODE neither -6, 0 nor 6, determines sign of * entries of D * 0 => leave entries of D unchanged * 1 => multiply each entry of D by random complex number * uniformly distributed with absolute value 1 * * IDIST - CHARACTER*1 * On entry, IDIST specifies the type of distribution to be * used to generate a random matrix . * 1 => real and imaginary parts each UNIFORM( 0, 1 ) * 2 => real and imaginary parts each UNIFORM( -1, 1 ) * 3 => real and imaginary parts each NORMAL( 0, 1 ) * 4 => complex number uniform in DISK( 0, 1 ) * Not modified. * * ISEED - INTEGER array, dimension ( 4 ) * On entry ISEED specifies the seed of the random number * generator. The random number generator uses a * linear congruential sequence limited to small * integers, and so should produce machine independent * random numbers. The values of ISEED are changed on * exit, and can be used in the next call to ZLATM1 * to continue the same random number sequence. * Changed on exit. * * D - COMPLEX*16 array, dimension ( MIN( M , N ) ) * Array to be computed according to MODE, COND and IRSIGN. * May be changed on exit if MODE is nonzero. * * N - INTEGER * Number of entries of D. Not modified. * * INFO - INTEGER * 0 => normal termination * -1 => if MODE not in range -6 to 6 * -2 => if MODE neither -6, 0 nor 6, and * IRSIGN neither 0 nor 1 * -3 => if MODE neither -6, 0 nor 6 and COND less than 1 * -4 => if MODE equals 6 or -6 and IDIST not in range 1 to 4 * -7 => if N negative * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) * .. * .. Local Scalars .. INTEGER I DOUBLE PRECISION ALPHA, TEMP COMPLEX*16 CTEMP * .. * .. External Functions .. DOUBLE PRECISION DLARAN COMPLEX*16 ZLARND EXTERNAL DLARAN, ZLARND * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARNV * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, EXP, LOG * .. * .. Executable Statements .. * * Decode and Test the input parameters. Initialize flags & seed. * INFO = 0 * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Set INFO if an error * IF( MODE.LT.-6 .OR. MODE.GT.6 ) THEN INFO = -1 ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND. $ ( IRSIGN.NE.0 .AND. IRSIGN.NE.1 ) ) THEN INFO = -2 ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND. $ COND.LT.ONE ) THEN INFO = -3 ELSE IF( ( MODE.EQ.6 .OR. MODE.EQ.-6 ) .AND. $ ( IDIST.LT.1 .OR. IDIST.GT.4 ) ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -7 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZLATM1', -INFO ) RETURN END IF * * Compute D according to COND and MODE * IF( MODE.NE.0 ) THEN GO TO ( 10, 30, 50, 70, 90, 110 )ABS( MODE ) * * One large D value: * 10 CONTINUE DO 20 I = 1, N D( I ) = ONE / COND 20 CONTINUE D( 1 ) = ONE GO TO 120 * * One small D value: * 30 CONTINUE DO 40 I = 1, N D( I ) = ONE 40 CONTINUE D( N ) = ONE / COND GO TO 120 * * Exponentially distributed D values: * 50 CONTINUE D( 1 ) = ONE IF( N.GT.1 ) THEN ALPHA = COND**( -ONE / DBLE( N-1 ) ) DO 60 I = 2, N D( I ) = ALPHA**( I-1 ) 60 CONTINUE END IF GO TO 120 * * Arithmetically distributed D values: * 70 CONTINUE D( 1 ) = ONE IF( N.GT.1 ) THEN TEMP = ONE / COND ALPHA = ( ONE-TEMP ) / DBLE( N-1 ) DO 80 I = 2, N D( I ) = DBLE( N-I )*ALPHA + TEMP 80 CONTINUE END IF GO TO 120 * * Randomly distributed D values on ( 1/COND , 1): * 90 CONTINUE ALPHA = LOG( ONE / COND ) DO 100 I = 1, N D( I ) = EXP( ALPHA*DLARAN( ISEED ) ) 100 CONTINUE GO TO 120 * * Randomly distributed D values from IDIST * 110 CONTINUE CALL ZLARNV( IDIST, ISEED, N, D ) * 120 CONTINUE * * If MODE neither -6 nor 0 nor 6, and IRSIGN = 1, assign * random signs to D * IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND. $ IRSIGN.EQ.1 ) THEN DO 130 I = 1, N CTEMP = ZLARND( 3, ISEED ) D( I ) = D( I )*( CTEMP / ABS( CTEMP ) ) 130 CONTINUE END IF * * Reverse if MODE < 0 * IF( MODE.LT.0 ) THEN DO 140 I = 1, N / 2 CTEMP = D( I ) D( I ) = D( N+1-I ) D( N+1-I ) = CTEMP 140 CONTINUE END IF * END IF * RETURN * * End of ZLATM1 * END SHAR_EOF fi # end of overwriting check if test -f 'zlatm2.f' then echo shar: will not over-write existing file "'zlatm2.f'" else cat << SHAR_EOF > 'zlatm2.f' DOUBLE COMPLEX FUNCTION ZLATM2( M, N, I, J, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE ) * * -- LAPACK auxiliary test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. * INTEGER I, IDIST, IGRADE, IPVTNG, J, KL, KU, M, N DOUBLE PRECISION SPARSE * .. * * .. Array Arguments .. * INTEGER ISEED( 4 ), IWORK( * ) COMPLEX*16 D( * ), DL( * ), DR( * ) * .. * * Purpose * ======= * * ZLATM2 returns the (I,J) entry of a random matrix of dimension * (M, N) described by the other paramters. It is called by the * ZLATMR routine in order to build random test matrices. No error * checking on parameters is done, because this routine is called in * a tight loop by ZLATMR which has already checked the parameters. * * Use of ZLATM2 differs from CLATM3 in the order in which the random * number generator is called to fill in random matrix entries. * With ZLATM2, the generator is called to fill in the pivoted matrix * columnwise. With ZLATM3, the generator is called to fill in the * matrix columnwise, after which it is pivoted. Thus, ZLATM3 can * be used to construct random matrices which differ only in their * order of rows and/or columns. ZLATM2 is used to construct band * matrices while avoiding calling the random number generator for * entries outside the band (and therefore generating random numbers * * The matrix whose (I,J) entry is returned is constructed as * follows (this routine only computes one entry): * * If I is outside (1..M) or J is outside (1..N), return zero * (this is convenient for generating matrices in band format). * * Generate a matrix A with random entries of distribution IDIST. * * Set the diagonal to D. * * Grade the matrix, if desired, from the left (by DL) and/or * from the right (by DR or DL) as specified by IGRADE. * * Permute, if desired, the rows and/or columns as specified by * IPVTNG and IWORK. * * Band the matrix to have lower bandwidth KL and upper * bandwidth KU. * * Set random entries to zero as specified by SPARSE. * * Arguments * ========= * * M - INTEGER * Number of rows of matrix. Not modified. * * N - INTEGER * Number of columns of matrix. Not modified. * * I - INTEGER * Row of entry to be returned. Not modified. * * J - INTEGER * Column of entry to be returned. Not modified. * * KL - INTEGER * Lower bandwidth. Not modified. * * KU - INTEGER * Upper bandwidth. Not modified. * * IDIST - INTEGER * On entry, IDIST specifies the type of distribution to be * used to generate a random matrix . * 1 => real and imaginary parts each UNIFORM( 0, 1 ) * 2 => real and imaginary parts each UNIFORM( -1, 1 ) * 3 => real and imaginary parts each NORMAL( 0, 1 ) * 4 => complex number uniform in DISK( 0 , 1 ) * Not modified. * * ISEED - INTEGER array of dimension ( 4 ) * Seed for random number generator. * Changed on exit. * * D - COMPLEX*16 array of dimension ( MIN( I , J ) ) * Diagonal entries of matrix. Not modified. * * IGRADE - INTEGER * Specifies grading of matrix as follows: * 0 => no grading * 1 => matrix premultiplied by diag( DL ) * 2 => matrix postmultiplied by diag( DR ) * 3 => matrix premultiplied by diag( DL ) and * postmultiplied by diag( DR ) * 4 => matrix premultiplied by diag( DL ) and * postmultiplied by inv( diag( DL ) ) * 5 => matrix premultiplied by diag( DL ) and * postmultiplied by diag( CONJG(DL) ) * 6 => matrix premultiplied by diag( DL ) and * postmultiplied by diag( DL ) * Not modified. * * DL - COMPLEX*16 array ( I or J, as appropriate ) * Left scale factors for grading matrix. Not modified. * * DR - COMPLEX*16 array ( I or J, as appropriate ) * Right scale factors for grading matrix. Not modified. * * IPVTNG - INTEGER * On entry specifies pivoting permutations as follows: * 0 => none. * 1 => row pivoting. * 2 => column pivoting. * 3 => full pivoting, i.e., on both sides. * Not modified. * * IWORK - INTEGER array ( I or J, as appropriate ) * This array specifies the permutation used. The * row (or column) in position K was originally in * position IWORK( K ). * This differs from IWORK for ZLATM3. Not modified. * * SPARSE - DOUBLE PRECISION between 0. and 1. * On entry specifies the sparsity of the matrix * if sparse matix is to be generated. * SPARSE should lie between 0 and 1. * A uniform ( 0, 1 ) random number x is generated and * compared to SPARSE; if x is larger the matrix entry * is unchanged and if x is smaller the entry is set * to zero. Thus on the average a fraction SPARSE of the * entries will be set to zero. * Not modified. * * ===================================================================== * * .. Parameters .. * COMPLEX*16 CZERO PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ) ) DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) * .. * * .. Local Scalars .. * INTEGER ISUB, JSUB COMPLEX*16 CTEMP * .. * * .. External Functions .. * DOUBLE PRECISION DLARAN COMPLEX*16 ZLARND EXTERNAL DLARAN, ZLARND * .. * * .. Intrinsic Functions .. * INTRINSIC DCONJG * .. * *----------------------------------------------------------------------- * * .. Executable Statements .. * * * Check for I and J in range * IF( I.LT.1 .OR. I.GT.M .OR. J.LT.1 .OR. J.GT.N ) THEN ZLATM2 = CZERO RETURN END IF * * Check for banding * IF( J.GT.I+KU .OR. J.LT.I-KL ) THEN ZLATM2 = CZERO RETURN END IF * * Check for sparsity * IF( SPARSE.GT.ZERO ) THEN IF( DLARAN( ISEED ).LT.SPARSE ) THEN ZLATM2 = CZERO RETURN END IF END IF * * Compute subscripts depending on IPVTNG * IF( IPVTNG.EQ.0 ) THEN ISUB = I JSUB = J ELSE IF( IPVTNG.EQ.1 ) THEN ISUB = IWORK( I ) JSUB = J ELSE IF( IPVTNG.EQ.2 ) THEN ISUB = I JSUB = IWORK( J ) ELSE IF( IPVTNG.EQ.3 ) THEN ISUB = IWORK( I ) JSUB = IWORK( J ) END IF * * Compute entry and grade it according to IGRADE * IF( ISUB.EQ.JSUB ) THEN CTEMP = D( ISUB ) ELSE CTEMP = ZLARND( IDIST, ISEED ) END IF IF( IGRADE.EQ.1 ) THEN CTEMP = CTEMP*DL( ISUB ) ELSE IF( IGRADE.EQ.2 ) THEN CTEMP = CTEMP*DR( JSUB ) ELSE IF( IGRADE.EQ.3 ) THEN CTEMP = CTEMP*DL( ISUB )*DR( JSUB ) ELSE IF( IGRADE.EQ.4 .AND. ISUB.NE.JSUB ) THEN CTEMP = CTEMP*DL( ISUB ) / DL( JSUB ) ELSE IF( IGRADE.EQ.5 ) THEN CTEMP = CTEMP*DL( ISUB )*DCONJG( DL( JSUB ) ) ELSE IF( IGRADE.EQ.6 ) THEN CTEMP = CTEMP*DL( ISUB )*DL( JSUB ) END IF ZLATM2 = CTEMP RETURN * * End of ZLATM2 * END SHAR_EOF fi # end of overwriting check if test -f 'zlatm3.f' then echo shar: will not over-write existing file "'zlatm3.f'" else cat << SHAR_EOF > 'zlatm3.f' DOUBLE COMPLEX FUNCTION ZLATM3( M, N, I, J, ISUB, JSUB, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, $ SPARSE ) * * -- LAPACK auxiliary test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. * INTEGER I, IDIST, IGRADE, IPVTNG, ISUB, J, JSUB, KL, $ KU, M, N DOUBLE PRECISION SPARSE * .. * * .. Array Arguments .. * INTEGER ISEED( 4 ), IWORK( * ) COMPLEX*16 D( * ), DL( * ), DR( * ) * .. * * Purpose * ======= * * ZLATM3 returns the (ISUB,JSUB) entry of a random matrix of * dimension (M, N) described by the other paramters. (ISUB,JSUB) * is the final position of the (I,J) entry after pivoting * according to IPVTNG and IWORK. ZLATM3 is called by the * ZLATMR routine in order to build random test matrices. No error * checking on parameters is done, because this routine is called in * a tight loop by ZLATMR which has already checked the parameters. * * Use of ZLATM3 differs from CLATM2 in the order in which the random * number generator is called to fill in random matrix entries. * With ZLATM2, the generator is called to fill in the pivoted matrix * columnwise. With ZLATM3, the generator is called to fill in the * matrix columnwise, after which it is pivoted. Thus, ZLATM3 can * be used to construct random matrices which differ only in their * order of rows and/or columns. ZLATM2 is used to construct band * matrices while avoiding calling the random number generator for * entries outside the band (and therefore generating random numbers * in different orders for different pivot orders). * * The matrix whose (ISUB,JSUB) entry is returned is constructed as * follows (this routine only computes one entry): * * If ISUB is outside (1..M) or JSUB is outside (1..N), return zero * (this is convenient for generating matrices in band format). * * Generate a matrix A with random entries of distribution IDIST. * * Set the diagonal to D. * * Grade the matrix, if desired, from the left (by DL) and/or * from the right (by DR or DL) as specified by IGRADE. * * Permute, if desired, the rows and/or columns as specified by * IPVTNG and IWORK. * * Band the matrix to have lower bandwidth KL and upper * bandwidth KU. * * Set random entries to zero as specified by SPARSE. * * Arguments * ========= * * M - INTEGER * Number of rows of matrix. Not modified. * * N - INTEGER * Number of columns of matrix. Not modified. * * I - INTEGER * Row of unpivoted entry to be returned. Not modified. * * J - INTEGER * Column of unpivoted entry to be returned. Not modified. * * ISUB - INTEGER * Row of pivoted entry to be returned. Changed on exit. * * JSUB - INTEGER * Column of pivoted entry to be returned. Changed on exit. * * KL - INTEGER * Lower bandwidth. Not modified. * * KU - INTEGER * Upper bandwidth. Not modified. * * IDIST - INTEGER * On entry, IDIST specifies the type of distribution to be * used to generate a random matrix . * 1 => real and imaginary parts each UNIFORM( 0, 1 ) * 2 => real and imaginary parts each UNIFORM( -1, 1 ) * 3 => real and imaginary parts each NORMAL( 0, 1 ) * 4 => complex number uniform in DISK( 0 , 1 ) * Not modified. * * ISEED - INTEGER array of dimension ( 4 ) * Seed for random number generator. * Changed on exit. * * D - COMPLEX*16 array of dimension ( MIN( I , J ) ) * Diagonal entries of matrix. Not modified. * * IGRADE - INTEGER * Specifies grading of matrix as follows: * 0 => no grading * 1 => matrix premultiplied by diag( DL ) * 2 => matrix postmultiplied by diag( DR ) * 3 => matrix premultiplied by diag( DL ) and * postmultiplied by diag( DR ) * 4 => matrix premultiplied by diag( DL ) and * postmultiplied by inv( diag( DL ) ) * 5 => matrix premultiplied by diag( DL ) and * postmultiplied by diag( CONJG(DL) ) * 6 => matrix premultiplied by diag( DL ) and * postmultiplied by diag( DL ) * Not modified. * * DL - COMPLEX*16 array ( I or J, as appropriate ) * Left scale factors for grading matrix. Not modified. * * DR - COMPLEX*16 array ( I or J, as appropriate ) * Right scale factors for grading matrix. Not modified. * * IPVTNG - INTEGER * On entry specifies pivoting permutations as follows: * 0 => none. * 1 => row pivoting. * 2 => column pivoting. * 3 => full pivoting, i.e., on both sides. * Not modified. * * IWORK - INTEGER array ( I or J, as appropriate ) * This array specifies the permutation used. The * row (or column) originally in position K is in * position IWORK( K ) after pivoting. * This differs from IWORK for ZLATM2. Not modified. * * SPARSE - DOUBLE PRECISION between 0. and 1. * On entry specifies the sparsity of the matrix * if sparse matix is to be generated. * SPARSE should lie between 0 and 1. * A uniform ( 0, 1 ) random number x is generated and * compared to SPARSE; if x is larger the matrix entry * is unchanged and if x is smaller the entry is set * to zero. Thus on the average a fraction SPARSE of the * entries will be set to zero. * Not modified. * * ===================================================================== * * .. Parameters .. * DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) COMPLEX*16 CZERO PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ) ) * .. * * .. Local Scalars .. * COMPLEX*16 CTEMP * .. * * .. External Functions .. * DOUBLE PRECISION DLARAN COMPLEX*16 ZLARND EXTERNAL DLARAN, ZLARND * .. * * .. Intrinsic Functions .. * INTRINSIC DCONJG * .. * *----------------------------------------------------------------------- * * .. Executable Statements .. * * * Check for I and J in range * IF( I.LT.1 .OR. I.GT.M .OR. J.LT.1 .OR. J.GT.N ) THEN ISUB = I JSUB = J ZLATM3 = CZERO RETURN END IF * * Compute subscripts depending on IPVTNG * IF( IPVTNG.EQ.0 ) THEN ISUB = I JSUB = J ELSE IF( IPVTNG.EQ.1 ) THEN ISUB = IWORK( I ) JSUB = J ELSE IF( IPVTNG.EQ.2 ) THEN ISUB = I JSUB = IWORK( J ) ELSE IF( IPVTNG.EQ.3 ) THEN ISUB = IWORK( I ) JSUB = IWORK( J ) END IF * * Check for banding * IF( JSUB.GT.ISUB+KU .OR. JSUB.LT.ISUB-KL ) THEN ZLATM3 = CZERO RETURN END IF * * Check for sparsity * IF( SPARSE.GT.ZERO ) THEN IF( DLARAN( ISEED ).LT.SPARSE ) THEN ZLATM3 = CZERO RETURN END IF END IF * * Compute entry and grade it according to IGRADE * IF( I.EQ.J ) THEN CTEMP = D( I ) ELSE CTEMP = ZLARND( IDIST, ISEED ) END IF IF( IGRADE.EQ.1 ) THEN CTEMP = CTEMP*DL( I ) ELSE IF( IGRADE.EQ.2 ) THEN CTEMP = CTEMP*DR( J ) ELSE IF( IGRADE.EQ.3 ) THEN CTEMP = CTEMP*DL( I )*DR( J ) ELSE IF( IGRADE.EQ.4 .AND. I.NE.J ) THEN CTEMP = CTEMP*DL( I ) / DL( J ) ELSE IF( IGRADE.EQ.5 ) THEN CTEMP = CTEMP*DL( I )*DCONJG( DL( J ) ) ELSE IF( IGRADE.EQ.6 ) THEN CTEMP = CTEMP*DL( I )*DL( J ) END IF ZLATM3 = CTEMP RETURN * * End of ZLATM3 * END SHAR_EOF fi # end of overwriting check if test -f 'zlatme.f' then echo shar: will not over-write existing file "'zlatme.f'" else cat << SHAR_EOF > 'zlatme.f' SUBROUTINE ZLATME( N, DIST, ISEED, D, MODE, COND, DMAX, EI, RSIGN, $ UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, A, $ LDA, WORK, INFO ) * * -- LAPACK test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER DIST, EI, RSIGN, SIM, UPPER INTEGER INFO, KL, KU, LDA, MODE, MODES, N DOUBLE PRECISION ANORM, COND, CONDS COMPLEX*16 DMAX * .. * .. Array Arguments .. INTEGER ISEED( 4 ) DOUBLE PRECISION DS( * ) COMPLEX*16 A( LDA, * ), D( * ), WORK( * ) * .. * * Purpose * ======= * * ZLATME generates random non-symmetric square matrices with * specified eigenvalues for testing LAPACK programs. * * ZLATME operates by applying the following sequence of * operations: * * 1. Set the diagonal to D, where D may be input or * computed according to MODE, COND, DMAX, and RSIGN * as described below. * * 2. If UPPER='T', the upper triangle of A is set to random values * out of distribution DIST. * * 3. If SIM='T', A is multiplied on the left by a random matrix * X, whose singular values are specified by DS, MODES, and * CONDS, and on the right by X inverse. * * 4. If KL < N-1, the lower bandwidth is reduced to KL using * Householder transformations. If KU < N-1, the upper * bandwidth is reduced to KU. * * 5. If ANORM is not negative, the matrix is scaled to have * maximum-element-norm ANORM. * * (Note: since the matrix cannot be reduced beyond Hessenberg form, * no packing options are available.) * * Arguments * ========= * * N - INTEGER * The number of columns (or rows) of A. Not modified. * * DIST - CHARACTER*1 * On entry, DIST specifies the type of distribution to be used * to generate the random eigen-/singular values, and on the * upper triangle (see UPPER). * 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) * 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) * 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) * 'D' => uniform on the complex disc |z| < 1. * Not modified. * * ISEED - INTEGER array, dimension ( 4 ) * On entry ISEED specifies the seed of the random number * generator. They should lie between 0 and 4095 inclusive, * and ISEED(4) should be odd. The random number generator * uses a linear congruential sequence limited to small * integers, and so should produce machine independent * random numbers. The values of ISEED are changed on * exit, and can be used in the next call to ZLATME * to continue the same random number sequence. * Changed on exit. * * D - COMPLEX*16 array, dimension ( N ) * This array is used to specify the eigenvalues of A. If * MODE=0, then D is assumed to contain the eigenvalues * otherwise they will be computed according to MODE, COND, * DMAX, and RSIGN and placed in D. * Modified if MODE is nonzero. * * MODE - INTEGER * On entry this describes how the eigenvalues are to * be specified: * MODE = 0 means use D as input * MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND * MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND * MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) * MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) * MODE = 5 sets D to random numbers in the range * ( 1/COND , 1 ) such that their logarithms * are uniformly distributed. * MODE = 6 set D to random numbers from same distribution * as the rest of the matrix. * MODE < 0 has the same meaning as ABS(MODE), except that * the order of the elements of D is reversed. * Thus if MODE is between 1 and 4, D has entries ranging * from 1 to 1/COND, if between -1 and -4, D has entries * ranging from 1/COND to 1, * Not modified. * * COND - DOUBLE PRECISION * On entry, this is used as described under MODE above. * If used, it must be >= 1. Not modified. * * DMAX - COMPLEX*16 * If MODE is neither -6, 0 nor 6, the contents of D, as * computed according to MODE and COND, will be scaled by * DMAX / max(abs(D(i))). Note that DMAX need not be * positive or real: if DMAX is negative or complex (or zero), * D will be scaled by a negative or complex number (or zero). * If RSIGN='F' then the largest (absolute) eigenvalue will be * equal to DMAX. * Not modified. * * EI - CHARACTER*1 (ignored) * Not modified. * * RSIGN - CHARACTER*1 * If MODE is not 0, 6, or -6, and RSIGN='T', then the * elements of D, as computed according to MODE and COND, will * be multiplied by a random complex number from the unit * circle |z| = 1. If RSIGN='F', they will not be. RSIGN may * only have the values 'T' or 'F'. * Not modified. * * UPPER - CHARACTER*1 * If UPPER='T', then the elements of A above the diagonal * will be set to random numbers out of DIST. If UPPER='F', * they will not. UPPER may only have the values 'T' or 'F'. * Not modified. * * SIM - CHARACTER*1 * If SIM='T', then A will be operated on by a "similarity * transform", i.e., multiplied on the left by a matrix X and * on the right by X inverse. X = U S V, where U and V are * random unitary matrices and S is a (diagonal) matrix of * singular values specified by DS, MODES, and CONDS. If * SIM='F', then A will not be transformed. * Not modified. * * DS - DOUBLE PRECISION array, dimension ( N ) * This array is used to specify the singular values of X, * in the same way that D specifies the eigenvalues of A. * If MODE=0, the DS contains the singular values, which * may not be zero. * Modified if MODE is nonzero. * * MODES - INTEGER * CONDS - DOUBLE PRECISION * Similar to MODE and COND, but for specifying the diagonal * of S. MODES=-6 and +6 are not allowed (since they would * result in randomly ill-conditioned eigenvalues.) * * KL - INTEGER * This specifies the lower bandwidth of the matrix. KL=1 * specifies upper Hessenberg form. If KL is at least N-1, * then A will have full lower bandwidth. * Not modified. * * KU - INTEGER * This specifies the upper bandwidth of the matrix. KU=1 * specifies lower Hessenberg form. If KU is at least N-1, * then A will have full upper bandwidth; if KU and KL * are both at least N-1, then A will be dense. Only one of * KU and KL may be less than N-1. * Not modified. * * ANORM - DOUBLE PRECISION * If ANORM is not negative, then A will be scaled by a non- * negative real number to make the maximum-element-norm of A * to be ANORM. * Not modified. * * A - COMPLEX*16 array, dimension ( LDA, N ) * On exit A is the desired test matrix. * Modified. * * LDA - INTEGER * LDA specifies the first dimension of A as declared in the * calling program. LDA must be at least M. * Not modified. * * WORK - COMPLEX*16 array, dimension ( 3*N ) * Workspace. * Modified. * * INFO - INTEGER * Error code. On exit, INFO will be set to one of the * following values: * 0 => normal return * -1 => N negative * -2 => DIST illegal string * -5 => MODE not in range -6 to 6 * -6 => COND less than 1.0, and MODE neither -6, 0 nor 6 * -9 => RSIGN is not 'T' or 'F' * -10 => UPPER is not 'T' or 'F' * -11 => SIM is not 'T' or 'F' * -12 => MODES=0 and DS has a zero singular value. * -13 => MODES is not in the range -5 to 5. * -14 => MODES is nonzero and CONDS is less than 1. * -15 => KL is less than 1. * -16 => KU is less than 1, or KL and KU are both less than * N-1. * -19 => LDA is less than M. * 1 => Error return from ZLATM1 (computing D) * 2 => Cannot scale to DMAX (max. eigenvalue is 0) * 3 => Error return from DLATM1 (computing DS) * 4 => Error return from ZLARGE * 5 => Zero singular value from DLATM1. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) COMPLEX*16 CZERO PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) COMPLEX*16 CONE PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL BADS INTEGER I, IC, ICOLS, IDIST, IINFO, IR, IROWS, IRSIGN, $ ISIM, IUPPER, J, JC, JCR DOUBLE PRECISION RALPHA, TEMP COMPLEX*16 ALPHA, TAU, XNORMS * .. * .. Local Arrays .. DOUBLE PRECISION TEMPA( 1 ) * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION ZLANGE COMPLEX*16 ZLARND EXTERNAL LSAME, ZLANGE, ZLARND * .. * .. External Subroutines .. EXTERNAL DLATM1, XERBLA, ZCOPY, ZDSCAL, ZGEMV, ZGERC, $ ZLACGV, ZLARFG, ZLARGE, ZLARNV, ZLASET, ZLATM1, $ ZSCAL * .. * .. Intrinsic Functions .. INTRINSIC ABS, DCONJG, MAX, MOD * .. * .. Executable Statements .. * * 1) Decode and Test the input parameters. * Initialize flags & seed. * INFO = 0 * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Decode DIST * IF( LSAME( DIST, 'U' ) ) THEN IDIST = 1 ELSE IF( LSAME( DIST, 'S' ) ) THEN IDIST = 2 ELSE IF( LSAME( DIST, 'N' ) ) THEN IDIST = 3 ELSE IF( LSAME( DIST, 'D' ) ) THEN IDIST = 4 ELSE IDIST = -1 END IF * * Decode RSIGN * IF( LSAME( RSIGN, 'T' ) ) THEN IRSIGN = 1 ELSE IF( LSAME( RSIGN, 'F' ) ) THEN IRSIGN = 0 ELSE IRSIGN = -1 END IF * * Decode UPPER * IF( LSAME( UPPER, 'T' ) ) THEN IUPPER = 1 ELSE IF( LSAME( UPPER, 'F' ) ) THEN IUPPER = 0 ELSE IUPPER = -1 END IF * * Decode SIM * IF( LSAME( SIM, 'T' ) ) THEN ISIM = 1 ELSE IF( LSAME( SIM, 'F' ) ) THEN ISIM = 0 ELSE ISIM = -1 END IF * * Check DS, if MODES=0 and ISIM=1 * BADS = .FALSE. IF( MODES.EQ.0 .AND. ISIM.EQ.1 ) THEN DO 10 J = 1, N IF( DS( J ).EQ.ZERO ) $ BADS = .TRUE. 10 CONTINUE END IF * * Set INFO if an error * IF( N.LT.0 ) THEN INFO = -1 ELSE IF( IDIST.EQ.-1 ) THEN INFO = -2 ELSE IF( ABS( MODE ).GT.6 ) THEN INFO = -5 ELSE IF( ( MODE.NE.0 .AND. ABS( MODE ).NE.6 ) .AND. COND.LT.ONE ) $ THEN INFO = -6 ELSE IF( IRSIGN.EQ.-1 ) THEN INFO = -9 ELSE IF( IUPPER.EQ.-1 ) THEN INFO = -10 ELSE IF( ISIM.EQ.-1 ) THEN INFO = -11 ELSE IF( BADS ) THEN INFO = -12 ELSE IF( ISIM.EQ.1 .AND. ABS( MODES ).GT.5 ) THEN INFO = -13 ELSE IF( ISIM.EQ.1 .AND. MODES.NE.0 .AND. CONDS.LT.ONE ) THEN INFO = -14 ELSE IF( KL.LT.1 ) THEN INFO = -15 ELSE IF( KU.LT.1 .OR. ( KU.LT.N-1 .AND. KL.LT.N-1 ) ) THEN INFO = -16 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -19 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZLATME', -INFO ) RETURN END IF * * Initialize random number generator * DO 20 I = 1, 4 ISEED( I ) = MOD( ABS( ISEED( I ) ), 4096 ) 20 CONTINUE * IF( MOD( ISEED( 4 ), 2 ).NE.1 ) $ ISEED( 4 ) = ISEED( 4 ) + 1 * * 2) Set up diagonal of A * * Compute D according to COND and MODE * CALL ZLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, IINFO ) IF( IINFO.NE.0 ) THEN INFO = 1 RETURN END IF IF( MODE.NE.0 .AND. ABS( MODE ).NE.6 ) THEN * * Scale by DMAX * TEMP = ABS( D( 1 ) ) DO 30 I = 2, N TEMP = MAX( TEMP, ABS( D( I ) ) ) 30 CONTINUE * IF( TEMP.GT.ZERO ) THEN ALPHA = DMAX / TEMP ELSE INFO = 2 RETURN END IF * CALL ZSCAL( N, ALPHA, D, 1 ) * END IF * CALL ZLASET( 'Full', N, N, CZERO, CZERO, A, LDA ) CALL ZCOPY( N, D, 1, A, LDA+1 ) * * 3) If UPPER='T', set upper triangle of A to random numbers. * IF( IUPPER.NE.0 ) THEN DO 40 JC = 2, N CALL ZLARNV( IDIST, ISEED, JC-1, A( 1, JC ) ) 40 CONTINUE END IF * * 4) If SIM='T', apply similarity transformation. * * -1 * Transform is X A X , where X = U S V, thus * * it is U S V A V' (1/S) U' * IF( ISIM.NE.0 ) THEN * * Compute S (singular values of the eigenvector matrix) * according to CONDS and MODES * CALL DLATM1( MODES, CONDS, 0, 0, ISEED, DS, N, IINFO ) IF( IINFO.NE.0 ) THEN INFO = 3 RETURN END IF * * Multiply by V and V' * CALL ZLARGE( N, A, LDA, ISEED, WORK, IINFO ) IF( IINFO.NE.0 ) THEN INFO = 4 RETURN END IF * * Multiply by S and (1/S) * DO 50 J = 1, N CALL ZDSCAL( N, DS( J ), A( J, 1 ), LDA ) IF( DS( J ).NE.ZERO ) THEN CALL ZDSCAL( N, ONE / DS( J ), A( 1, J ), 1 ) ELSE INFO = 5 RETURN END IF 50 CONTINUE * * Multiply by U and U' * CALL ZLARGE( N, A, LDA, ISEED, WORK, IINFO ) IF( IINFO.NE.0 ) THEN INFO = 4 RETURN END IF END IF * * 5) Reduce the bandwidth. * IF( KL.LT.N-1 ) THEN * * Reduce bandwidth -- kill column * DO 60 JCR = KL + 1, N - 1 IC = JCR - KL IROWS = N + 1 - JCR ICOLS = N + KL - JCR * CALL ZCOPY( IROWS, A( JCR, IC ), 1, WORK, 1 ) XNORMS = WORK( 1 ) CALL ZLARFG( IROWS, XNORMS, WORK( 2 ), 1, TAU ) TAU = DCONJG( TAU ) WORK( 1 ) = CONE ALPHA = ZLARND( 5, ISEED ) * CALL ZGEMV( 'C', IROWS, ICOLS, CONE, A( JCR, IC+1 ), LDA, $ WORK, 1, CZERO, WORK( IROWS+1 ), 1 ) CALL ZGERC( IROWS, ICOLS, -TAU, WORK, 1, WORK( IROWS+1 ), 1, $ A( JCR, IC+1 ), LDA ) * CALL ZGEMV( 'N', N, IROWS, CONE, A( 1, JCR ), LDA, WORK, 1, $ CZERO, WORK( IROWS+1 ), 1 ) CALL ZGERC( N, IROWS, -DCONJG( TAU ), WORK( IROWS+1 ), 1, $ WORK, 1, A( 1, JCR ), LDA ) * A( JCR, IC ) = XNORMS CALL ZLASET( 'Full', IROWS-1, 1, CZERO, CZERO, $ A( JCR+1, IC ), LDA ) * CALL ZSCAL( ICOLS+1, ALPHA, A( JCR, IC ), LDA ) CALL ZSCAL( N, DCONJG( ALPHA ), A( 1, JCR ), 1 ) 60 CONTINUE ELSE IF( KU.LT.N-1 ) THEN * * Reduce upper bandwidth -- kill a row at a time. * DO 70 JCR = KU + 1, N - 1 IR = JCR - KU IROWS = N + KU - JCR ICOLS = N + 1 - JCR * CALL ZCOPY( ICOLS, A( IR, JCR ), LDA, WORK, 1 ) XNORMS = WORK( 1 ) CALL ZLARFG( ICOLS, XNORMS, WORK( 2 ), 1, TAU ) TAU = DCONJG( TAU ) WORK( 1 ) = CONE CALL ZLACGV( ICOLS-1, WORK( 2 ), 1 ) ALPHA = ZLARND( 5, ISEED ) * CALL ZGEMV( 'N', IROWS, ICOLS, CONE, A( IR+1, JCR ), LDA, $ WORK, 1, CZERO, WORK( ICOLS+1 ), 1 ) CALL ZGERC( IROWS, ICOLS, -TAU, WORK( ICOLS+1 ), 1, WORK, 1, $ A( IR+1, JCR ), LDA ) * CALL ZGEMV( 'C', ICOLS, N, CONE, A( JCR, 1 ), LDA, WORK, 1, $ CZERO, WORK( ICOLS+1 ), 1 ) CALL ZGERC( ICOLS, N, -DCONJG( TAU ), WORK, 1, $ WORK( ICOLS+1 ), 1, A( JCR, 1 ), LDA ) * A( IR, JCR ) = XNORMS CALL ZLASET( 'Full', 1, ICOLS-1, CZERO, CZERO, $ A( IR, JCR+1 ), LDA ) * CALL ZSCAL( IROWS+1, ALPHA, A( IR, JCR ), 1 ) CALL ZSCAL( N, DCONJG( ALPHA ), A( JCR, 1 ), LDA ) 70 CONTINUE END IF * * Scale the matrix to have norm ANORM * IF( ANORM.GE.ZERO ) THEN TEMP = ZLANGE( 'M', N, N, A, LDA, TEMPA ) IF( TEMP.GT.ZERO ) THEN RALPHA = ANORM / TEMP DO 80 J = 1, N CALL ZDSCAL( N, RALPHA, A( 1, J ), 1 ) 80 CONTINUE END IF END IF * RETURN * * End of ZLATME * END SHAR_EOF fi # end of overwriting check if test -f 'zlatmr.f' then echo shar: will not over-write existing file "'zlatmr.f'" else cat << SHAR_EOF > 'zlatmr.f' SUBROUTINE ZLATMR( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, $ RSIGN, GRADE, DL, MODEL, CONDL, DR, MODER, $ CONDR, PIVTNG, IPIVOT, KL, KU, SPARSE, ANORM, $ PACK, A, LDA, IWORK, INFO ) * * -- LAPACK test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER DIST, GRADE, PACK, PIVTNG, RSIGN, SYM INTEGER INFO, KL, KU, LDA, M, MODE, MODEL, MODER, N DOUBLE PRECISION ANORM, COND, CONDL, CONDR, SPARSE COMPLEX*16 DMAX * .. * .. Array Arguments .. INTEGER IPIVOT( * ), ISEED( 4 ), IWORK( * ) COMPLEX*16 A( LDA, * ), D( * ), DL( * ), DR( * ) * .. * * Purpose * ======= * * ZLATMR generates random matrices of various types for testing * LAPACK programs. * * ZLATMR operates by applying the following sequence of * operations: * * Generate a matrix A with random entries of distribution DIST * which is symmetric if SYM='S', Hermitian if SYM='H', and * nonsymmetric if SYM='N'. * * Set the diagonal to D, where D may be input or * computed according to MODE, COND, DMAX and RSIGN * as described below. * * Grade the matrix, if desired, from the left and/or right * as specified by GRADE. The inputs DL, MODEL, CONDL, DR, * MODER and CONDR also determine the grading as described * below. * * Permute, if desired, the rows and/or columns as specified by * PIVTNG and IPIVOT. * * Set random entries to zero, if desired, to get a random sparse * matrix as specified by SPARSE. * * Make A a band matrix, if desired, by zeroing out the matrix * outside a band of lower bandwidth KL and upper bandwidth KU. * * Scale A, if desired, to have maximum entry ANORM. * * Pack the matrix if desired. Options specified by PACK are: * no packing * zero out upper half (if symmetric or Hermitian) * zero out lower half (if symmetric or Hermitian) * store the upper half columnwise (if symmetric or Hermitian * or square upper triangular) * store the lower half columnwise (if symmetric or Hermitian * or square lower triangular) * same as upper half rowwise if symmetric * same as conjugate upper half rowwise if Hermitian * store the lower triangle in banded format * (if symmetric or Hermitian) * store the upper triangle in banded format * (if symmetric or Hermitian) * store the entire matrix in banded format * * Note: If two calls to ZLATMR differ only in the PACK parameter, * they will generate mathematically equivalent matrices. * * If two calls to ZLATMR both have full bandwidth (KL = M-1 * and KU = N-1), and differ only in the PIVTNG and PACK * parameters, then the matrices generated will differ only * in the order of the rows and/or columns, and otherwise * contain the same data. This consistency cannot be and * is not maintained with less than full bandwidth. * * Arguments * ========= * * M - INTEGER * Number of rows of A. Not modified. * * N - INTEGER * Number of columns of A. Not modified. * * DIST - CHARACTER*1 * On entry, DIST specifies the type of distribution to be used * to generate a random matrix . * 'U' => real and imaginary parts are independent * UNIFORM( 0, 1 ) ( 'U' for uniform ) * 'S' => real and imaginary parts are independent * UNIFORM( -1, 1 ) ( 'S' for symmetric ) * 'N' => real and imaginary parts are independent * NORMAL( 0, 1 ) ( 'N' for normal ) * 'D' => uniform on interior of unit disk ( 'D' for disk ) * Not modified. * * ISEED - INTEGER array, dimension (4) * On entry ISEED specifies the seed of the random number * generator. They should lie between 0 and 4095 inclusive, * and ISEED(4) should be odd. The random number generator * uses a linear congruential sequence limited to small * integers, and so should produce machine independent * random numbers. The values of ISEED are changed on * exit, and can be used in the next call to ZLATMR * to continue the same random number sequence. * Changed on exit. * * SYM - CHARACTER*1 * If SYM='S', generated matrix is symmetric. * If SYM='H', generated matrix is Hermitian. * If SYM='N', generated matrix is nonsymmetric. * Not modified. * * D - COMPLEX*16 array, dimension (min(M,N)) * On entry this array specifies the diagonal entries * of the diagonal of A. D may either be specified * on entry, or set according to MODE and COND as described * below. If the matrix is Hermitian, the real part of D * will be taken. May be changed on exit if MODE is nonzero. * * MODE - INTEGER * On entry describes how D is to be used: * MODE = 0 means use D as input * MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND * MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND * MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) * MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) * MODE = 5 sets D to random numbers in the range * ( 1/COND , 1 ) such that their logarithms * are uniformly distributed. * MODE = 6 set D to random numbers from same distribution * as the rest of the matrix. * MODE < 0 has the same meaning as ABS(MODE), except that * the order of the elements of D is reversed. * Thus if MODE is positive, D has entries ranging from * 1 to 1/COND, if negative, from 1/COND to 1, * Not modified. * * COND - DOUBLE PRECISION * On entry, used as described under MODE above. * If used, it must be >= 1. Not modified. * * DMAX - COMPLEX*16 * If MODE neither -6, 0 nor 6, the diagonal is scaled by * DMAX / max(abs(D(i))), so that maximum absolute entry * of diagonal is abs(DMAX). If DMAX is complex (or zero), * diagonal will be scaled by a complex number (or zero). * * RSIGN - CHARACTER*1 * If MODE neither -6, 0 nor 6, specifies sign of diagonal * as follows: * 'T' => diagonal entries are multiplied by a random complex * number uniformly distributed with absolute value 1 * 'F' => diagonal unchanged * Not modified. * * GRADE - CHARACTER*1 * Specifies grading of matrix as follows: * 'N' => no grading * 'L' => matrix premultiplied by diag( DL ) * (only if matrix nonsymmetric) * 'R' => matrix postmultiplied by diag( DR ) * (only if matrix nonsymmetric) * 'B' => matrix premultiplied by diag( DL ) and * postmultiplied by diag( DR ) * (only if matrix nonsymmetric) * 'H' => matrix premultiplied by diag( DL ) and * postmultiplied by diag( CONJG(DL) ) * (only if matrix Hermitian or nonsymmetric) * 'S' => matrix premultiplied by diag( DL ) and * postmultiplied by diag( DL ) * (only if matrix symmetric or nonsymmetric) * 'E' => matrix premultiplied by diag( DL ) and * postmultiplied by inv( diag( DL ) ) * ( 'S' for similarity ) * (only if matrix nonsymmetric) * Note: if GRADE='S', then M must equal N. * Not modified. * * DL - COMPLEX*16 array, dimension (M) * If MODEL=0, then on entry this array specifies the diagonal * entries of a diagonal matrix used as described under GRADE * above. If MODEL is not zero, then DL will be set according * to MODEL and CONDL, analogous to the way D is set according * to MODE and COND (except there is no DMAX parameter for DL). * If GRADE='E', then DL cannot have zero entries. * Not referenced if GRADE = 'N' or 'R'. Changed on exit. * * MODEL - INTEGER * This specifies how the diagonal array DL is to be computed, * just as MODE specifies how D is to be computed. * Not modified. * * CONDL - DOUBLE PRECISION * When MODEL is not zero, this specifies the condition number * of the computed DL. Not modified. * * DR - COMPLEX*16 array, dimension (N) * If MODER=0, then on entry this array specifies the diagonal * entries of a diagonal matrix used as described under GRADE * above. If MODER is not zero, then DR will be set according * to MODER and CONDR, analogous to the way D is set according * to MODE and COND (except there is no DMAX parameter for DR). * Not referenced if GRADE = 'N', 'L', 'H' or 'S'. * Changed on exit. * * MODER - INTEGER * This specifies how the diagonal array DR is to be computed, * just as MODE specifies how D is to be computed. * Not modified. * * CONDR - DOUBLE PRECISION * When MODER is not zero, this specifies the condition number * of the computed DR. Not modified. * * PIVTNG - CHARACTER*1 * On entry specifies pivoting permutations as follows: * 'N' or ' ' => none. * 'L' => left or row pivoting (matrix must be nonsymmetric). * 'R' => right or column pivoting (matrix must be * nonsymmetric). * 'B' or 'F' => both or full pivoting, i.e., on both sides. * In this case, M must equal N * * If two calls to ZLATMR both have full bandwidth (KL = M-1 * and KU = N-1), and differ only in the PIVTNG and PACK * parameters, then the matrices generated will differ only * in the order of the rows and/or columns, and otherwise * contain the same data. This consistency cannot be * maintained with less than full bandwidth. * * IPIVOT - INTEGER array, dimension (N or M) * This array specifies the permutation used. After the * basic matrix is generated, the rows, columns, or both * are permuted. If, say, row pivoting is selected, ZLATMR * starts with the *last* row and interchanges the M-th and * IPIVOT(M)-th rows, then moves to the next-to-last row, * interchanging the (M-1)-th and the IPIVOT(M-1)-th rows, * and so on. In terms of "2-cycles", the permutation is * (1 IPIVOT(1)) (2 IPIVOT(2)) ... (M IPIVOT(M)) * where the rightmost cycle is applied first. This is the * *inverse* of the effect of pivoting in LINPACK. The idea * is that factoring (with pivoting) an identity matrix * which has been inverse-pivoted in this way should * result in a pivot vector identical to IPIVOT. * Not referenced if PIVTNG = 'N'. Not modified. * * SPARSE - DOUBLE PRECISION * On entry specifies the sparsity of the matrix if a sparse * matrix is to be generated. SPARSE should lie between * 0 and 1. To generate a sparse matrix, for each matrix entry * a uniform ( 0, 1 ) random number x is generated and * compared to SPARSE; if x is larger the matrix entry * is unchanged and if x is smaller the entry is set * to zero. Thus on the average a fraction SPARSE of the * entries will be set to zero. * Not modified. * * KL - INTEGER * On entry specifies the lower bandwidth of the matrix. For * example, KL=0 implies upper triangular, KL=1 implies upper * Hessenberg, and KL at least M-1 implies the matrix is not * banded. Must equal KU if matrix is symmetric or Hermitian. * Not modified. * * KU - INTEGER * On entry specifies the upper bandwidth of the matrix. For * example, KU=0 implies lower triangular, KU=1 implies lower * Hessenberg, and KU at least N-1 implies the matrix is not * banded. Must equal KL if matrix is symmetric or Hermitian. * Not modified. * * ANORM - DOUBLE PRECISION * On entry specifies maximum entry of output matrix * (output matrix will by multiplied by a constant so that * its largest absolute entry equal ANORM) * if ANORM is nonnegative. If ANORM is negative no scaling * is done. Not modified. * * PACK - CHARACTER*1 * On entry specifies packing of matrix as follows: * 'N' => no packing * 'U' => zero out all subdiagonal entries * (if symmetric or Hermitian) * 'L' => zero out all superdiagonal entries * (if symmetric or Hermitian) * 'C' => store the upper triangle columnwise * (only if matrix symmetric or Hermitian or * square upper triangular) * 'R' => store the lower triangle columnwise * (only if matrix symmetric or Hermitian or * square lower triangular) * (same as upper half rowwise if symmetric) * (same as conjugate upper half rowwise if Hermitian) * 'B' => store the lower triangle in band storage scheme * (only if matrix symmetric or Hermitian) * 'Q' => store the upper triangle in band storage scheme * (only if matrix symmetric or Hermitian) * 'Z' => store the entire matrix in band storage scheme * (pivoting can be provided for by using this * option to store A in the trailing rows of * the allocated storage) * * Using these options, the various LAPACK packed and banded * storage schemes can be obtained: * GB - use 'Z' * PB, HB or TB - use 'B' or 'Q' * PP, HP or TP - use 'C' or 'R' * * If two calls to ZLATMR differ only in the PACK parameter, * they will generate mathematically equivalent matrices. * Not modified. * * A - COMPLEX*16 array, dimension (LDA,N) * On exit A is the desired test matrix. Only those * entries of A which are significant on output * will be referenced (even if A is in packed or band * storage format). The 'unoccupied corners' of A in * band format will be zeroed out. * * LDA - INTEGER * on entry LDA specifies the first dimension of A as * declared in the calling program. * If PACK='N', 'U' or 'L', LDA must be at least max ( 1, M ). * If PACK='C' or 'R', LDA must be at least 1. * If PACK='B', or 'Q', LDA must be MIN ( KU+1, N ) * If PACK='Z', LDA must be at least KUU+KLL+1, where * KUU = MIN ( KU, N-1 ) and KLL = MIN ( KL, N-1 ) * Not modified. * * IWORK - INTEGER array, dimension (N or M) * Workspace. Not referenced if PIVTNG = 'N'. Changed on exit. * * INFO - INTEGER * Error parameter on exit: * 0 => normal return * -1 => M negative or unequal to N and SYM='S' or 'H' * -2 => N negative * -3 => DIST illegal string * -5 => SYM illegal string * -7 => MODE not in range -6 to 6 * -8 => COND less than 1.0, and MODE neither -6, 0 nor 6 * -10 => MODE neither -6, 0 nor 6 and RSIGN illegal string * -11 => GRADE illegal string, or GRADE='E' and * M not equal to N, or GRADE='L', 'R', 'B', 'S' or 'E' * and SYM = 'H', or GRADE='L', 'R', 'B', 'H' or 'E' * and SYM = 'S' * -12 => GRADE = 'E' and DL contains zero * -13 => MODEL not in range -6 to 6 and GRADE= 'L', 'B', 'H', * 'S' or 'E' * -14 => CONDL less than 1.0, GRADE='L', 'B', 'H', 'S' or 'E', * and MODEL neither -6, 0 nor 6 * -16 => MODER not in range -6 to 6 and GRADE= 'R' or 'B' * -17 => CONDR less than 1.0, GRADE='R' or 'B', and * MODER neither -6, 0 nor 6 * -18 => PIVTNG illegal string, or PIVTNG='B' or 'F' and * M not equal to N, or PIVTNG='L' or 'R' and SYM='S' * or 'H' * -19 => IPIVOT contains out of range number and * PIVTNG not equal to 'N' * -20 => KL negative * -21 => KU negative, or SYM='S' or 'H' and KU not equal to KL * -22 => SPARSE not in range 0. to 1. * -24 => PACK illegal string, or PACK='U', 'L', 'B' or 'Q' * and SYM='N', or PACK='C' and SYM='N' and either KL * not equal to 0 or N not equal to M, or PACK='R' and * SYM='N', and either KU not equal to 0 or N not equal * to M * -26 => LDA too small * 1 => Error return from ZLATM1 (computing D) * 2 => Cannot scale diagonal to DMAX (max. entry is 0) * 3 => Error return from ZLATM1 (computing DL) * 4 => Error return from ZLATM1 (computing DR) * 5 => ANORM is positive, but matrix constructed prior to * attempting to scale it to have norm ANORM, is zero * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) COMPLEX*16 CONE PARAMETER ( CONE = ( 1.0D0, 0.0D0 ) ) COMPLEX*16 CZERO PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ) ) * .. * .. Local Scalars .. LOGICAL BADPVT, DZERO, FULBND INTEGER I, IDIST, IGRADE, IISUB, IPACK, IPVTNG, IRSIGN, $ ISUB, ISYM, J, JJSUB, JSUB, K, KLL, KUU, MNMIN, $ MNSUB, MXSUB, NPVTS DOUBLE PRECISION ONORM, TEMP COMPLEX*16 CALPHA, CTEMP * .. * .. Local Arrays .. DOUBLE PRECISION TEMPA( 1 ) * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION ZLANGB, ZLANGE, ZLANSB, ZLANSP, ZLANSY COMPLEX*16 ZLATM2, ZLATM3 EXTERNAL LSAME, ZLANGB, ZLANGE, ZLANSB, ZLANSP, ZLANSY, $ ZLATM2, ZLATM3 * .. * .. External Subroutines .. EXTERNAL XERBLA, ZDSCAL, ZLATM1 * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCONJG, MAX, MIN, MOD * .. * .. Executable Statements .. * * 1) Decode and Test the input parameters. * Initialize flags & seed. * INFO = 0 * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * * Decode DIST * IF( LSAME( DIST, 'U' ) ) THEN IDIST = 1 ELSE IF( LSAME( DIST, 'S' ) ) THEN IDIST = 2 ELSE IF( LSAME( DIST, 'N' ) ) THEN IDIST = 3 ELSE IF( LSAME( DIST, 'D' ) ) THEN IDIST = 4 ELSE IDIST = -1 END IF * * Decode SYM * IF( LSAME( SYM, 'H' ) ) THEN ISYM = 0 ELSE IF( LSAME( SYM, 'N' ) ) THEN ISYM = 1 ELSE IF( LSAME( SYM, 'S' ) ) THEN ISYM = 2 ELSE ISYM = -1 END IF * * Decode RSIGN * IF( LSAME( RSIGN, 'F' ) ) THEN IRSIGN = 0 ELSE IF( LSAME( RSIGN, 'T' ) ) THEN IRSIGN = 1 ELSE IRSIGN = -1 END IF * * Decode PIVTNG * IF( LSAME( PIVTNG, 'N' ) ) THEN IPVTNG = 0 ELSE IF( LSAME( PIVTNG, ' ' ) ) THEN IPVTNG = 0 ELSE IF( LSAME( PIVTNG, 'L' ) ) THEN IPVTNG = 1 NPVTS = M ELSE IF( LSAME( PIVTNG, 'R' ) ) THEN IPVTNG = 2 NPVTS = N ELSE IF( LSAME( PIVTNG, 'B' ) ) THEN IPVTNG = 3 NPVTS = MIN( N, M ) ELSE IF( LSAME( PIVTNG, 'F' ) ) THEN IPVTNG = 3 NPVTS = MIN( N, M ) ELSE IPVTNG = -1 END IF * * Decode GRADE * IF( LSAME( GRADE, 'N' ) ) THEN IGRADE = 0 ELSE IF( LSAME( GRADE, 'L' ) ) THEN IGRADE = 1 ELSE IF( LSAME( GRADE, 'R' ) ) THEN IGRADE = 2 ELSE IF( LSAME( GRADE, 'B' ) ) THEN IGRADE = 3 ELSE IF( LSAME( GRADE, 'E' ) ) THEN IGRADE = 4 ELSE IF( LSAME( GRADE, 'H' ) ) THEN IGRADE = 5 ELSE IF( LSAME( GRADE, 'S' ) ) THEN IGRADE = 6 ELSE IGRADE = -1 END IF * * Decode PACK * IF( LSAME( PACK, 'N' ) ) THEN IPACK = 0 ELSE IF( LSAME( PACK, 'U' ) ) THEN IPACK = 1 ELSE IF( LSAME( PACK, 'L' ) ) THEN IPACK = 2 ELSE IF( LSAME( PACK, 'C' ) ) THEN IPACK = 3 ELSE IF( LSAME( PACK, 'R' ) ) THEN IPACK = 4 ELSE IF( LSAME( PACK, 'B' ) ) THEN IPACK = 5 ELSE IF( LSAME( PACK, 'Q' ) ) THEN IPACK = 6 ELSE IF( LSAME( PACK, 'Z' ) ) THEN IPACK = 7 ELSE IPACK = -1 END IF * * Set certain internal parameters * MNMIN = MIN( M, N ) KLL = MIN( KL, M-1 ) KUU = MIN( KU, N-1 ) * * If inv(DL) is used, check to see if DL has a zero entry. * DZERO = .FALSE. IF( IGRADE.EQ.4 .AND. MODEL.EQ.0 ) THEN DO 10 I = 1, M IF( DL( I ).EQ.CZERO ) $ DZERO = .TRUE. 10 CONTINUE END IF * * Check values in IPIVOT * BADPVT = .FALSE. IF( IPVTNG.GT.0 ) THEN DO 20 J = 1, NPVTS IF( IPIVOT( J ).LE.0 .OR. IPIVOT( J ).GT.NPVTS ) $ BADPVT = .TRUE. 20 CONTINUE END IF * * Set INFO if an error * IF( M.LT.0 ) THEN INFO = -1 ELSE IF( M.NE.N .AND. ( ISYM.EQ.0 .OR. ISYM.EQ.2 ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( IDIST.EQ.-1 ) THEN INFO = -3 ELSE IF( ISYM.EQ.-1 ) THEN INFO = -5 ELSE IF( MODE.LT.-6 .OR. MODE.GT.6 ) THEN INFO = -7 ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND. $ COND.LT.ONE ) THEN INFO = -8 ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND. $ IRSIGN.EQ.-1 ) THEN INFO = -10 ELSE IF( IGRADE.EQ.-1 .OR. ( IGRADE.EQ.4 .AND. M.NE.N ) .OR. $ ( ( IGRADE.EQ.1 .OR. IGRADE.EQ.2 .OR. IGRADE.EQ.3 .OR. $ IGRADE.EQ.4 .OR. IGRADE.EQ.6 ) .AND. ISYM.EQ.0 ) .OR. $ ( ( IGRADE.EQ.1 .OR. IGRADE.EQ.2 .OR. IGRADE.EQ.3 .OR. $ IGRADE.EQ.4 .OR. IGRADE.EQ.5 ) .AND. ISYM.EQ.2 ) ) THEN INFO = -11 ELSE IF( IGRADE.EQ.4 .AND. DZERO ) THEN INFO = -12 ELSE IF( ( IGRADE.EQ.1 .OR. IGRADE.EQ.3 .OR. IGRADE.EQ.4 .OR. $ IGRADE.EQ.5 .OR. IGRADE.EQ.6 ) .AND. $ ( MODEL.LT.-6 .OR. MODEL.GT.6 ) ) THEN INFO = -13 ELSE IF( ( IGRADE.EQ.1 .OR. IGRADE.EQ.3 .OR. IGRADE.EQ.4 .OR. $ IGRADE.EQ.5 .OR. IGRADE.EQ.6 ) .AND. $ ( MODEL.NE.-6 .AND. MODEL.NE.0 .AND. MODEL.NE.6 ) .AND. $ CONDL.LT.ONE ) THEN INFO = -14 ELSE IF( ( IGRADE.EQ.2 .OR. IGRADE.EQ.3 ) .AND. $ ( MODER.LT.-6 .OR. MODER.GT.6 ) ) THEN INFO = -16 ELSE IF( ( IGRADE.EQ.2 .OR. IGRADE.EQ.3 ) .AND. $ ( MODER.NE.-6 .AND. MODER.NE.0 .AND. MODER.NE.6 ) .AND. $ CONDR.LT.ONE ) THEN INFO = -17 ELSE IF( IPVTNG.EQ.-1 .OR. ( IPVTNG.EQ.3 .AND. M.NE.N ) .OR. $ ( ( IPVTNG.EQ.1 .OR. IPVTNG.EQ.2 ) .AND. ( ISYM.EQ.0 .OR. $ ISYM.EQ.2 ) ) ) THEN INFO = -18 ELSE IF( IPVTNG.NE.0 .AND. BADPVT ) THEN INFO = -19 ELSE IF( KL.LT.0 ) THEN INFO = -20 ELSE IF( KU.LT.0 .OR. ( ( ISYM.EQ.0 .OR. ISYM.EQ.2 ) .AND. KL.NE. $ KU ) ) THEN INFO = -21 ELSE IF( SPARSE.LT.ZERO .OR. SPARSE.GT.ONE ) THEN INFO = -22 ELSE IF( IPACK.EQ.-1 .OR. ( ( IPACK.EQ.1 .OR. IPACK.EQ.2 .OR. $ IPACK.EQ.5 .OR. IPACK.EQ.6 ) .AND. ISYM.EQ.1 ) .OR. $ ( IPACK.EQ.3 .AND. ISYM.EQ.1 .AND. ( KL.NE.0 .OR. M.NE. $ N ) ) .OR. ( IPACK.EQ.4 .AND. ISYM.EQ.1 .AND. ( KU.NE. $ 0 .OR. M.NE.N ) ) ) THEN INFO = -24 ELSE IF( ( ( IPACK.EQ.0 .OR. IPACK.EQ.1 .OR. IPACK.EQ.2 ) .AND. $ LDA.LT.MAX( 1, M ) ) .OR. ( ( IPACK.EQ.3 .OR. IPACK.EQ. $ 4 ) .AND. LDA.LT.1 ) .OR. ( ( IPACK.EQ.5 .OR. IPACK.EQ. $ 6 ) .AND. LDA.LT.KUU+1 ) .OR. $ ( IPACK.EQ.7 .AND. LDA.LT.KLL+KUU+1 ) ) THEN INFO = -26 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZLATMR', -INFO ) RETURN END IF * * Decide if we can pivot consistently * FULBND = .FALSE. IF( KUU.EQ.N-1 .AND. KLL.EQ.M-1 ) $ FULBND = .TRUE. * * Initialize random number generator * DO 30 I = 1, 4 ISEED( I ) = MOD( ABS( ISEED( I ) ), 4096 ) 30 CONTINUE * ISEED( 4 ) = 2*( ISEED( 4 ) / 2 ) + 1 * * 2) Set up D, DL, and DR, if indicated. * * Compute D according to COND and MODE * CALL ZLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, MNMIN, INFO ) IF( INFO.NE.0 ) THEN INFO = 1 RETURN END IF IF( MODE.NE.0 .AND. MODE.NE.-6 .AND. MODE.NE.6 ) THEN * * Scale by DMAX * TEMP = ABS( D( 1 ) ) DO 40 I = 2, MNMIN TEMP = MAX( TEMP, ABS( D( I ) ) ) 40 CONTINUE IF( TEMP.EQ.ZERO .AND. DMAX.NE.CZERO ) THEN INFO = 2 RETURN END IF IF( TEMP.NE.ZERO ) THEN CALPHA = DMAX / TEMP ELSE CALPHA = CONE END IF DO 50 I = 1, MNMIN D( I ) = CALPHA*D( I ) 50 CONTINUE * END IF * * If matrix Hermitian, make D real * IF( ISYM.EQ.0 ) THEN DO 60 I = 1, MNMIN D( I ) = DBLE( D( I ) ) 60 CONTINUE END IF * * Compute DL if grading set * IF( IGRADE.EQ.1 .OR. IGRADE.EQ.3 .OR. IGRADE.EQ.4 .OR. IGRADE.EQ. $ 5 .OR. IGRADE.EQ.6 ) THEN CALL ZLATM1( MODEL, CONDL, 0, IDIST, ISEED, DL, M, INFO ) IF( INFO.NE.0 ) THEN INFO = 3 RETURN END IF END IF * * Compute DR if grading set * IF( IGRADE.EQ.2 .OR. IGRADE.EQ.3 ) THEN CALL ZLATM1( MODER, CONDR, 0, IDIST, ISEED, DR, N, INFO ) IF( INFO.NE.0 ) THEN INFO = 4 RETURN END IF END IF * * 3) Generate IWORK if pivoting * IF( IPVTNG.GT.0 ) THEN DO 70 I = 1, NPVTS IWORK( I ) = I 70 CONTINUE IF( FULBND ) THEN DO 80 I = 1, NPVTS K = IPIVOT( I ) J = IWORK( I ) IWORK( I ) = IWORK( K ) IWORK( K ) = J 80 CONTINUE ELSE DO 90 I = NPVTS, 1, -1 K = IPIVOT( I ) J = IWORK( I ) IWORK( I ) = IWORK( K ) IWORK( K ) = J 90 CONTINUE END IF END IF * * 4) Generate matrices for each kind of PACKing * Always sweep matrix columnwise (if symmetric, upper * half only) so that matrix generated does not depend * on PACK * IF( FULBND ) THEN * * Use ZLATM3 so matrices generated with differing PIVOTing only * differ only in the order of their rows and/or columns. * IF( IPACK.EQ.0 ) THEN IF( ISYM.EQ.0 ) THEN DO 110 J = 1, N DO 100 I = 1, J CTEMP = ZLATM3( M, N, I, J, ISUB, JSUB, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) A( ISUB, JSUB ) = CTEMP A( JSUB, ISUB ) = DCONJG( CTEMP ) 100 CONTINUE 110 CONTINUE ELSE IF( ISYM.EQ.1 ) THEN DO 130 J = 1, N DO 120 I = 1, M CTEMP = ZLATM3( M, N, I, J, ISUB, JSUB, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) A( ISUB, JSUB ) = CTEMP 120 CONTINUE 130 CONTINUE ELSE IF( ISYM.EQ.2 ) THEN DO 150 J = 1, N DO 140 I = 1, J CTEMP = ZLATM3( M, N, I, J, ISUB, JSUB, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) A( ISUB, JSUB ) = CTEMP A( JSUB, ISUB ) = CTEMP 140 CONTINUE 150 CONTINUE END IF * ELSE IF( IPACK.EQ.1 ) THEN * DO 170 J = 1, N DO 160 I = 1, J CTEMP = ZLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, $ SPARSE ) MNSUB = MIN( ISUB, JSUB ) MXSUB = MAX( ISUB, JSUB ) IF( MXSUB.EQ.ISUB .AND. ISYM.EQ.0 ) THEN A( MNSUB, MXSUB ) = DCONJG( CTEMP ) ELSE A( MNSUB, MXSUB ) = CTEMP END IF IF( MNSUB.NE.MXSUB ) $ A( MXSUB, MNSUB ) = CZERO 160 CONTINUE 170 CONTINUE * ELSE IF( IPACK.EQ.2 ) THEN * DO 190 J = 1, N DO 180 I = 1, J CTEMP = ZLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, $ SPARSE ) MNSUB = MIN( ISUB, JSUB ) MXSUB = MAX( ISUB, JSUB ) IF( MXSUB.EQ.JSUB .AND. ISYM.EQ.0 ) THEN A( MXSUB, MNSUB ) = DCONJG( CTEMP ) ELSE A( MXSUB, MNSUB ) = CTEMP END IF IF( MNSUB.NE.MXSUB ) $ A( MNSUB, MXSUB ) = CZERO 180 CONTINUE 190 CONTINUE * ELSE IF( IPACK.EQ.3 ) THEN * DO 210 J = 1, N DO 200 I = 1, J CTEMP = ZLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, $ SPARSE ) * * Compute K = location of (ISUB,JSUB) entry in packed * array * MNSUB = MIN( ISUB, JSUB ) MXSUB = MAX( ISUB, JSUB ) K = MXSUB*( MXSUB-1 ) / 2 + MNSUB * * Convert K to (IISUB,JJSUB) location * JJSUB = ( K-1 ) / LDA + 1 IISUB = K - LDA*( JJSUB-1 ) * IF( MXSUB.EQ.ISUB .AND. ISYM.EQ.0 ) THEN A( IISUB, JJSUB ) = DCONJG( CTEMP ) ELSE A( IISUB, JJSUB ) = CTEMP END IF 200 CONTINUE 210 CONTINUE * ELSE IF( IPACK.EQ.4 ) THEN * DO 230 J = 1, N DO 220 I = 1, J CTEMP = ZLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, $ SPARSE ) * * Compute K = location of (I,J) entry in packed array * MNSUB = MIN( ISUB, JSUB ) MXSUB = MAX( ISUB, JSUB ) IF( MNSUB.EQ.1 ) THEN K = MXSUB ELSE K = N*( N+1 ) / 2 - ( N-MNSUB+1 )*( N-MNSUB+2 ) / $ 2 + MXSUB - MNSUB + 1 END IF * * Convert K to (IISUB,JJSUB) location * JJSUB = ( K-1 ) / LDA + 1 IISUB = K - LDA*( JJSUB-1 ) * IF( MXSUB.EQ.JSUB .AND. ISYM.EQ.0 ) THEN A( IISUB, JJSUB ) = DCONJG( CTEMP ) ELSE A( IISUB, JJSUB ) = CTEMP END IF 220 CONTINUE 230 CONTINUE * ELSE IF( IPACK.EQ.5 ) THEN * DO 250 J = 1, N DO 240 I = J - KUU, J IF( I.LT.1 ) THEN A( J-I+1, I+N ) = CZERO ELSE CTEMP = ZLATM3( M, N, I, J, ISUB, JSUB, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) MNSUB = MIN( ISUB, JSUB ) MXSUB = MAX( ISUB, JSUB ) IF( MXSUB.EQ.JSUB .AND. ISYM.EQ.0 ) THEN A( MXSUB-MNSUB+1, MNSUB ) = DCONJG( CTEMP ) ELSE A( MXSUB-MNSUB+1, MNSUB ) = CTEMP END IF END IF 240 CONTINUE 250 CONTINUE * ELSE IF( IPACK.EQ.6 ) THEN * DO 270 J = 1, N DO 260 I = J - KUU, J CTEMP = ZLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, $ SPARSE ) MNSUB = MIN( ISUB, JSUB ) MXSUB = MAX( ISUB, JSUB ) IF( MXSUB.EQ.ISUB .AND. ISYM.EQ.0 ) THEN A( MNSUB-MXSUB+KUU+1, MXSUB ) = DCONJG( CTEMP ) ELSE A( MNSUB-MXSUB+KUU+1, MXSUB ) = CTEMP END IF 260 CONTINUE 270 CONTINUE * ELSE IF( IPACK.EQ.7 ) THEN * IF( ISYM.NE.1 ) THEN DO 290 J = 1, N DO 280 I = J - KUU, J CTEMP = ZLATM3( M, N, I, J, ISUB, JSUB, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) MNSUB = MIN( ISUB, JSUB ) MXSUB = MAX( ISUB, JSUB ) IF( I.LT.1 ) $ A( J-I+1+KUU, I+N ) = CZERO IF( MXSUB.EQ.ISUB .AND. ISYM.EQ.0 ) THEN A( MNSUB-MXSUB+KUU+1, MXSUB ) = DCONJG( CTEMP ) ELSE A( MNSUB-MXSUB+KUU+1, MXSUB ) = CTEMP END IF IF( I.GE.1 .AND. MNSUB.NE.MXSUB ) THEN IF( MNSUB.EQ.ISUB .AND. ISYM.EQ.0 ) THEN A( MXSUB-MNSUB+1+KUU, $ MNSUB ) = DCONJG( CTEMP ) ELSE A( MXSUB-MNSUB+1+KUU, MNSUB ) = CTEMP END IF END IF 280 CONTINUE 290 CONTINUE ELSE IF( ISYM.EQ.1 ) THEN DO 310 J = 1, N DO 300 I = J - KUU, J + KLL CTEMP = ZLATM3( M, N, I, J, ISUB, JSUB, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) A( ISUB-JSUB+KUU+1, JSUB ) = CTEMP 300 CONTINUE 310 CONTINUE END IF * END IF * ELSE * * Use ZLATM2 * IF( IPACK.EQ.0 ) THEN IF( ISYM.EQ.0 ) THEN DO 330 J = 1, N DO 320 I = 1, J A( I, J ) = ZLATM2( M, N, I, J, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) A( J, I ) = DCONJG( A( I, J ) ) 320 CONTINUE 330 CONTINUE ELSE IF( ISYM.EQ.1 ) THEN DO 350 J = 1, N DO 340 I = 1, M A( I, J ) = ZLATM2( M, N, I, J, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) 340 CONTINUE 350 CONTINUE ELSE IF( ISYM.EQ.2 ) THEN DO 370 J = 1, N DO 360 I = 1, J A( I, J ) = ZLATM2( M, N, I, J, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) A( J, I ) = A( I, J ) 360 CONTINUE 370 CONTINUE END IF * ELSE IF( IPACK.EQ.1 ) THEN * DO 390 J = 1, N DO 380 I = 1, J A( I, J ) = ZLATM2( M, N, I, J, KL, KU, IDIST, ISEED, $ D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE ) IF( I.NE.J ) $ A( J, I ) = CZERO 380 CONTINUE 390 CONTINUE * ELSE IF( IPACK.EQ.2 ) THEN * DO 410 J = 1, N DO 400 I = 1, J IF( ISYM.EQ.0 ) THEN A( J, I ) = DCONJG( ZLATM2( M, N, I, J, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, DR, $ IPVTNG, IWORK, SPARSE ) ) ELSE A( J, I ) = ZLATM2( M, N, I, J, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) END IF IF( I.NE.J ) $ A( I, J ) = CZERO 400 CONTINUE 410 CONTINUE * ELSE IF( IPACK.EQ.3 ) THEN * ISUB = 0 JSUB = 1 DO 430 J = 1, N DO 420 I = 1, J ISUB = ISUB + 1 IF( ISUB.GT.LDA ) THEN ISUB = 1 JSUB = JSUB + 1 END IF A( ISUB, JSUB ) = ZLATM2( M, N, I, J, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) 420 CONTINUE 430 CONTINUE * ELSE IF( IPACK.EQ.4 ) THEN * IF( ISYM.EQ.0 .OR. ISYM.EQ.2 ) THEN DO 450 J = 1, N DO 440 I = 1, J * * Compute K = location of (I,J) entry in packed array * IF( I.EQ.1 ) THEN K = J ELSE K = N*( N+1 ) / 2 - ( N-I+1 )*( N-I+2 ) / 2 + $ J - I + 1 END IF * * Convert K to (ISUB,JSUB) location * JSUB = ( K-1 ) / LDA + 1 ISUB = K - LDA*( JSUB-1 ) * A( ISUB, JSUB ) = ZLATM2( M, N, I, J, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, DR, $ IPVTNG, IWORK, SPARSE ) IF( ISYM.EQ.0 ) $ A( ISUB, JSUB ) = DCONJG( A( ISUB, JSUB ) ) 440 CONTINUE 450 CONTINUE ELSE ISUB = 0 JSUB = 1 DO 470 J = 1, N DO 460 I = J, M ISUB = ISUB + 1 IF( ISUB.GT.LDA ) THEN ISUB = 1 JSUB = JSUB + 1 END IF A( ISUB, JSUB ) = ZLATM2( M, N, I, J, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, DR, $ IPVTNG, IWORK, SPARSE ) 460 CONTINUE 470 CONTINUE END IF * ELSE IF( IPACK.EQ.5 ) THEN * DO 490 J = 1, N DO 480 I = J - KUU, J IF( I.LT.1 ) THEN A( J-I+1, I+N ) = CZERO ELSE IF( ISYM.EQ.0 ) THEN A( J-I+1, I ) = DCONJG( ZLATM2( M, N, I, J, KL, $ KU, IDIST, ISEED, D, IGRADE, DL, $ DR, IPVTNG, IWORK, SPARSE ) ) ELSE A( J-I+1, I ) = ZLATM2( M, N, I, J, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, DR, $ IPVTNG, IWORK, SPARSE ) END IF END IF 480 CONTINUE 490 CONTINUE * ELSE IF( IPACK.EQ.6 ) THEN * DO 510 J = 1, N DO 500 I = J - KUU, J A( I-J+KUU+1, J ) = ZLATM2( M, N, I, J, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, $ IWORK, SPARSE ) 500 CONTINUE 510 CONTINUE * ELSE IF( IPACK.EQ.7 ) THEN * IF( ISYM.NE.1 ) THEN DO 530 J = 1, N DO 520 I = J - KUU, J A( I-J+KUU+1, J ) = ZLATM2( M, N, I, J, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, $ DR, IPVTNG, IWORK, SPARSE ) IF( I.LT.1 ) $ A( J-I+1+KUU, I+N ) = CZERO IF( I.GE.1 .AND. I.NE.J ) THEN IF( ISYM.EQ.0 ) THEN A( J-I+1+KUU, I ) = DCONJG( A( I-J+KUU+1, $ J ) ) ELSE A( J-I+1+KUU, I ) = A( I-J+KUU+1, J ) END IF END IF 520 CONTINUE 530 CONTINUE ELSE IF( ISYM.EQ.1 ) THEN DO 550 J = 1, N DO 540 I = J - KUU, J + KLL A( I-J+KUU+1, J ) = ZLATM2( M, N, I, J, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, $ DR, IPVTNG, IWORK, SPARSE ) 540 CONTINUE 550 CONTINUE END IF * END IF * END IF * * 5) Scaling the norm * IF( IPACK.EQ.0 ) THEN ONORM = ZLANGE( 'M', M, N, A, LDA, TEMPA ) ELSE IF( IPACK.EQ.1 ) THEN ONORM = ZLANSY( 'M', 'U', N, A, LDA, TEMPA ) ELSE IF( IPACK.EQ.2 ) THEN ONORM = ZLANSY( 'M', 'L', N, A, LDA, TEMPA ) ELSE IF( IPACK.EQ.3 ) THEN ONORM = ZLANSP( 'M', 'U', N, A, TEMPA ) ELSE IF( IPACK.EQ.4 ) THEN ONORM = ZLANSP( 'M', 'L', N, A, TEMPA ) ELSE IF( IPACK.EQ.5 ) THEN ONORM = ZLANSB( 'M', 'L', N, KLL, A, LDA, TEMPA ) ELSE IF( IPACK.EQ.6 ) THEN ONORM = ZLANSB( 'M', 'U', N, KUU, A, LDA, TEMPA ) ELSE IF( IPACK.EQ.7 ) THEN ONORM = ZLANGB( 'M', N, KLL, KUU, A, LDA, TEMPA ) END IF * IF( ANORM.GE.ZERO ) THEN * IF( ANORM.GT.ZERO .AND. ONORM.EQ.ZERO ) THEN * * Desired scaling impossible * INFO = 5 RETURN * ELSE IF( ( ANORM.GT.ONE .AND. ONORM.LT.ONE ) .OR. $ ( ANORM.LT.ONE .AND. ONORM.GT.ONE ) ) THEN * * Scale carefully to avoid over / underflow * IF( IPACK.LE.2 ) THEN DO 560 J = 1, N CALL ZDSCAL( M, ONE / ONORM, A( 1, J ), 1 ) CALL ZDSCAL( M, ANORM, A( 1, J ), 1 ) 560 CONTINUE * ELSE IF( IPACK.EQ.3 .OR. IPACK.EQ.4 ) THEN * CALL ZDSCAL( N*( N+1 ) / 2, ONE / ONORM, A, 1 ) CALL ZDSCAL( N*( N+1 ) / 2, ANORM, A, 1 ) * ELSE IF( IPACK.GE.5 ) THEN * DO 570 J = 1, N CALL ZDSCAL( KLL+KUU+1, ONE / ONORM, A( 1, J ), 1 ) CALL ZDSCAL( KLL+KUU+1, ANORM, A( 1, J ), 1 ) 570 CONTINUE * END IF * ELSE * * Scale straightforwardly * IF( IPACK.LE.2 ) THEN DO 580 J = 1, N CALL ZDSCAL( M, ANORM / ONORM, A( 1, J ), 1 ) 580 CONTINUE * ELSE IF( IPACK.EQ.3 .OR. IPACK.EQ.4 ) THEN * CALL ZDSCAL( N*( N+1 ) / 2, ANORM / ONORM, A, 1 ) * ELSE IF( IPACK.GE.5 ) THEN * DO 590 J = 1, N CALL ZDSCAL( KLL+KUU+1, ANORM / ONORM, A( 1, J ), 1 ) 590 CONTINUE END IF * END IF * END IF * * End of ZLATMR * END SHAR_EOF fi # end of overwriting check if test -f 'zlatms.f' then echo shar: will not over-write existing file "'zlatms.f'" else cat << SHAR_EOF > 'zlatms.f' SUBROUTINE ZLATMS( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, $ KL, KU, PACK, A, LDA, WORK, INFO ) * * -- LAPACK test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER DIST, PACK, SYM INTEGER INFO, KL, KU, LDA, M, MODE, N DOUBLE PRECISION COND, DMAX * .. * .. Array Arguments .. INTEGER ISEED( 4 ) DOUBLE PRECISION D( * ) COMPLEX*16 A( LDA, * ), WORK( * ) * .. * * Purpose * ======= * * ZLATMS generates random matrices with specified singular values * (or hermitian with specified eigenvalues) * for testing LAPACK programs. * * ZLATMS operates by applying the following sequence of * operations: * * Set the diagonal to D, where D may be input or * computed according to MODE, COND, DMAX, and SYM * as described below. * * Generate a matrix with the appropriate band structure, by one * of two methods: * * Method A: * Generate a dense M x N matrix by multiplying D on the left * and the right by random unitary matrices, then: * * Reduce the bandwidth according to KL and KU, using * Householder transformations. * * Method B: * Convert the bandwidth-0 (i.e., diagonal) matrix to a * bandwidth-1 matrix using Givens rotations, "chasing" * out-of-band elements back, much as in QR; then convert * the bandwidth-1 to a bandwidth-2 matrix, etc. Note * that for reasonably small bandwidths (relative to M and * N) this requires less storage, as a dense matrix is not * generated. Also, for hermitian or symmetric matrices, * only one triangle is generated. * * Method A is chosen if the bandwidth is a large fraction of the * order of the matrix, and LDA is at least M (so a dense * matrix can be stored.) Method B is chosen if the bandwidth * is small (< 1/2 N for hermitian or symmetric, < .3 N+M for * non-symmetric), or LDA is less than M and not less than the * bandwidth. * * Pack the matrix if desired. Options specified by PACK are: * no packing * zero out upper half (if hermitian) * zero out lower half (if hermitian) * store the upper half columnwise (if hermitian or upper * triangular) * store the lower half columnwise (if hermitian or lower * triangular) * store the lower triangle in banded format (if hermitian or * lower triangular) * store the upper triangle in banded format (if hermitian or * upper triangular) * store the entire matrix in banded format * If Method B is chosen, and band format is specified, then the * matrix will be generated in the band format, so no repacking * will be necessary. * * Arguments * ========= * * M - INTEGER * The number of rows of A. Not modified. * * N - INTEGER * The number of columns of A. N must equal M if the matrix * is symmetric or hermitian (i.e., if SYM is not 'N') * Not modified. * * DIST - CHARACTER*1 * On entry, DIST specifies the type of distribution to be used * to generate the random eigen-/singular values. * 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) * 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) * 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) * Not modified. * * ISEED - INTEGER array, dimension ( 4 ) * On entry ISEED specifies the seed of the random number * generator. They should lie between 0 and 4095 inclusive, * and ISEED(4) should be odd. The random number generator * uses a linear congruential sequence limited to small * integers, and so should produce machine independent * random numbers. The values of ISEED are changed on * exit, and can be used in the next call to ZLATMS * to continue the same random number sequence. * Changed on exit. * * SYM - CHARACTER*1 * If SYM='H', the generated matrix is hermitian, with * eigenvalues specified by D, COND, MODE, and DMAX; they * may be positive, negative, or zero. * If SYM='P', the generated matrix is hermitian, with * eigenvalues (= singular values) specified by D, COND, * MODE, and DMAX; they will not be negative. * If SYM='N', the generated matrix is nonsymmetric, with * singular values specified by D, COND, MODE, and DMAX; * they will not be negative. * If SYM='S', the generated matrix is (complex) symmetric, * with singular values specified by D, COND, MODE, and * DMAX; they will not be negative. * Not modified. * * D - DOUBLE PRECISION array, dimension ( MIN( M, N ) ) * This array is used to specify the singular values or * eigenvalues of A (see SYM, above.) If MODE=0, then D is * assumed to contain the singular/eigenvalues, otherwise * they will be computed according to MODE, COND, and DMAX, * and placed in D. * Modified if MODE is nonzero. * * MODE - INTEGER * On entry this describes how the singular/eigenvalues are to * be specified: * MODE = 0 means use D as input * MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND * MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND * MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) * MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) * MODE = 5 sets D to random numbers in the range * ( 1/COND , 1 ) such that their logarithms * are uniformly distributed. * MODE = 6 set D to random numbers from same distribution * as the rest of the matrix. * MODE < 0 has the same meaning as ABS(MODE), except that * the order of the elements of D is reversed. * Thus if MODE is positive, D has entries ranging from * 1 to 1/COND, if negative, from 1/COND to 1, * If SYM='H', and MODE is neither 0, 6, nor -6, then * the elements of D will also be multiplied by a random * sign (i.e., +1 or -1.) * Not modified. * * COND - DOUBLE PRECISION * On entry, this is used as described under MODE above. * If used, it must be >= 1. Not modified. * * DMAX - DOUBLE PRECISION * If MODE is neither -6, 0 nor 6, the contents of D, as * computed according to MODE and COND, will be scaled by * DMAX / max(abs(D(i))); thus, the maximum absolute eigen- or * singular value (which is to say the norm) will be abs(DMAX). * Note that DMAX need not be positive: if DMAX is negative * (or zero), D will be scaled by a negative number (or zero). * Not modified. * * KL - INTEGER * This specifies the lower bandwidth of the matrix. For * example, KL=0 implies upper triangular, KL=1 implies upper * Hessenberg, and KL being at least M-1 means that the matrix * has full lower bandwidth. KL must equal KU if the matrix * is symmetric or hermitian. * Not modified. * * KU - INTEGER * This specifies the upper bandwidth of the matrix. For * example, KU=0 implies lower triangular, KU=1 implies lower * Hessenberg, and KU being at least N-1 means that the matrix * has full upper bandwidth. KL must equal KU if the matrix * is symmetric or hermitian. * Not modified. * * PACK - CHARACTER*1 * This specifies packing of matrix as follows: * 'N' => no packing * 'U' => zero out all subdiagonal entries (if symmetric * or hermitian) * 'L' => zero out all superdiagonal entries (if symmetric * or hermitian) * 'C' => store the upper triangle columnwise (only if the * matrix is symmetric, hermitian, or upper triangular) * 'R' => store the lower triangle columnwise (only if the * matrix is symmetric, hermitian, or lower triangular) * 'B' => store the lower triangle in band storage scheme * (only if the matrix is symmetric, hermitian, or * lower triangular) * 'Q' => store the upper triangle in band storage scheme * (only if the matrix is symmetric, hermitian, or * upper triangular) * 'Z' => store the entire matrix in band storage scheme * (pivoting can be provided for by using this * option to store A in the trailing rows of * the allocated storage) * * Using these options, the various LAPACK packed and banded * storage schemes can be obtained: * GB - use 'Z' * PB, SB, HB, or TB - use 'B' or 'Q' * PP, SP, HB, or TP - use 'C' or 'R' * * If two calls to ZLATMS differ only in the PACK parameter, * they will generate mathematically equivalent matrices. * Not modified. * * A - COMPLEX*16 array, dimension ( LDA, N ) * On exit A is the desired test matrix. A is first generated * in full (unpacked) form, and then packed, if so specified * by PACK. Thus, the first M elements of the first N * columns will always be modified. If PACK specifies a * packed or banded storage scheme, all LDA elements of the * first N columns will be modified; the elements of the * array which do not correspond to elements of the generated * matrix are set to zero. * Modified. * * LDA - INTEGER * LDA specifies the first dimension of A as declared in the * calling program. If PACK='N', 'U', 'L', 'C', or 'R', then * LDA must be at least M. If PACK='B' or 'Q', then LDA must * be at least MIN( KL, M-1) (which is equal to MIN(KU,N-1)). * If PACK='Z', LDA must be large enough to hold the packed * array: MIN( KU, N-1) + MIN( KL, M-1) + 1. * Not modified. * * WORK - COMPLEX*16 array, dimension ( 3*MAX( N, M ) ) * Workspace. * Modified. * * INFO - INTEGER * Error code. On exit, INFO will be set to one of the * following values: * 0 => normal return * -1 => M negative or unequal to N and SYM='S', 'H', or 'P' * -2 => N negative * -3 => DIST illegal string * -5 => SYM illegal string * -7 => MODE not in range -6 to 6 * -8 => COND less than 1.0, and MODE neither -6, 0 nor 6 * -10 => KL negative * -11 => KU negative, or SYM is not 'N' and KU is not equal to * KL * -12 => PACK illegal string, or PACK='U' or 'L', and SYM='N'; * or PACK='C' or 'Q' and SYM='N' and KL is not zero; * or PACK='R' or 'B' and SYM='N' and KU is not zero; * or PACK='U', 'L', 'C', 'R', 'B', or 'Q', and M is not * N. * -14 => LDA is less than M, or PACK='Z' and LDA is less than * MIN(KU,N-1) + MIN(KL,M-1) + 1. * 1 => Error return from DLATM1 * 2 => Cannot scale to DMAX (max. sing. value is 0) * 3 => Error return from ZLAGGE, CLAGHE or CLAGSY * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) COMPLEX*16 CZERO PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) DOUBLE PRECISION TWOPI PARAMETER ( TWOPI = 6.2831853071795864769252867663D+0 ) * .. * .. Local Scalars .. LOGICAL GIVENS, ILEXTR, ILTEMP, TOPDWN, ZSYM INTEGER I, IC, ICOL, IDIST, IENDCH, IINFO, IL, ILDA, $ IOFFG, IOFFST, IPACK, IPACKG, IR, IR1, IR2, $ IROW, IRSIGN, ISKEW, ISYM, ISYMPK, J, JC, JCH, $ JKL, JKU, JR, K, LLB, MINLDA, MNMIN, MR, NC, $ UUB DOUBLE PRECISION ALPHA, ANGLE, REALC, TEMP COMPLEX*16 C, CT, CTEMP, DUMMY, EXTRA, S, ST * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLARND COMPLEX*16 ZLARND EXTERNAL LSAME, DLARND, ZLARND * .. * .. External Subroutines .. EXTERNAL DLATM1, DSCAL, XERBLA, ZLAGGE, ZLAGHE, ZLAGSY, $ ZLAROT, ZLARTG, ZLASET * .. * .. Intrinsic Functions .. INTRINSIC ABS, COS, DBLE, DCMPLX, DCONJG, MAX, MIN, MOD, $ SIN * .. * .. Executable Statements .. * * 1) Decode and Test the input parameters. * Initialize flags & seed. * INFO = 0 * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * * Decode DIST * IF( LSAME( DIST, 'U' ) ) THEN IDIST = 1 ELSE IF( LSAME( DIST, 'S' ) ) THEN IDIST = 2 ELSE IF( LSAME( DIST, 'N' ) ) THEN IDIST = 3 ELSE IDIST = -1 END IF * * Decode SYM * IF( LSAME( SYM, 'N' ) ) THEN ISYM = 1 IRSIGN = 0 ZSYM = .FALSE. ELSE IF( LSAME( SYM, 'P' ) ) THEN ISYM = 2 IRSIGN = 0 ZSYM = .FALSE. ELSE IF( LSAME( SYM, 'S' ) ) THEN ISYM = 2 IRSIGN = 0 ZSYM = .TRUE. ELSE IF( LSAME( SYM, 'H' ) ) THEN ISYM = 2 IRSIGN = 1 ZSYM = .FALSE. ELSE ISYM = -1 END IF * * Decode PACK * ISYMPK = 0 IF( LSAME( PACK, 'N' ) ) THEN IPACK = 0 ELSE IF( LSAME( PACK, 'U' ) ) THEN IPACK = 1 ISYMPK = 1 ELSE IF( LSAME( PACK, 'L' ) ) THEN IPACK = 2 ISYMPK = 1 ELSE IF( LSAME( PACK, 'C' ) ) THEN IPACK = 3 ISYMPK = 2 ELSE IF( LSAME( PACK, 'R' ) ) THEN IPACK = 4 ISYMPK = 3 ELSE IF( LSAME( PACK, 'B' ) ) THEN IPACK = 5 ISYMPK = 3 ELSE IF( LSAME( PACK, 'Q' ) ) THEN IPACK = 6 ISYMPK = 2 ELSE IF( LSAME( PACK, 'Z' ) ) THEN IPACK = 7 ELSE IPACK = -1 END IF * * Set certain internal parameters * MNMIN = MIN( M, N ) LLB = MIN( KL, M-1 ) UUB = MIN( KU, N-1 ) MR = MIN( M, N+LLB ) NC = MIN( N, M+UUB ) * IF( IPACK.EQ.5 .OR. IPACK.EQ.6 ) THEN MINLDA = UUB + 1 ELSE IF( IPACK.EQ.7 ) THEN MINLDA = LLB + UUB + 1 ELSE MINLDA = M END IF * * Use Givens rotation method if bandwidth small enough, * or if LDA is too small to store the matrix unpacked. * GIVENS = .FALSE. IF( ISYM.EQ.1 ) THEN IF( DBLE( LLB+UUB ).LT.0.3D0*DBLE( MAX( 1, MR+NC ) ) ) $ GIVENS = .TRUE. ELSE IF( 2*LLB.LT.M ) $ GIVENS = .TRUE. END IF IF( LDA.LT.M .AND. LDA.GE.MINLDA ) $ GIVENS = .TRUE. * * Set INFO if an error * IF( M.LT.0 ) THEN INFO = -1 ELSE IF( M.NE.N .AND. ISYM.NE.1 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( IDIST.EQ.-1 ) THEN INFO = -3 ELSE IF( ISYM.EQ.-1 ) THEN INFO = -5 ELSE IF( ABS( MODE ).GT.6 ) THEN INFO = -7 ELSE IF( ( MODE.NE.0 .AND. ABS( MODE ).NE.6 ) .AND. COND.LT.ONE ) $ THEN INFO = -8 ELSE IF( KL.LT.0 ) THEN INFO = -10 ELSE IF( KU.LT.0 .OR. ( ISYM.NE.1 .AND. KL.NE.KU ) ) THEN INFO = -11 ELSE IF( IPACK.EQ.-1 .OR. ( ISYMPK.EQ.1 .AND. ISYM.EQ.1 ) .OR. $ ( ISYMPK.EQ.2 .AND. ISYM.EQ.1 .AND. KL.GT.0 ) .OR. $ ( ISYMPK.EQ.3 .AND. ISYM.EQ.1 .AND. KU.GT.0 ) .OR. $ ( ISYMPK.NE.0 .AND. M.NE.N ) ) THEN INFO = -12 ELSE IF( LDA.LT.MAX( 1, MINLDA ) ) THEN INFO = -14 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZLATMS', -INFO ) RETURN END IF * * Initialize random number generator * DO 10 I = 1, 4 ISEED( I ) = MOD( ABS( ISEED( I ) ), 4096 ) 10 CONTINUE * IF( MOD( ISEED( 4 ), 2 ).NE.1 ) $ ISEED( 4 ) = ISEED( 4 ) + 1 * * 2) Set up D if indicated. * * Compute D according to COND and MODE * CALL DLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, MNMIN, IINFO ) IF( IINFO.NE.0 ) THEN INFO = 1 RETURN END IF * * Choose Top-Down if D is (apparently) increasing, * Bottom-Up if D is (apparently) decreasing. * IF( ABS( D( 1 ) ).LE.ABS( D( MNMIN ) ) ) THEN TOPDWN = .TRUE. ELSE TOPDWN = .FALSE. END IF * IF( MODE.NE.0 .AND. ABS( MODE ).NE.6 ) THEN * * Scale by DMAX * TEMP = ABS( D( 1 ) ) DO 20 I = 2, MNMIN TEMP = MAX( TEMP, ABS( D( I ) ) ) 20 CONTINUE * IF( TEMP.GT.ZERO ) THEN ALPHA = DMAX / TEMP ELSE INFO = 2 RETURN END IF * CALL DSCAL( MNMIN, ALPHA, D, 1 ) * END IF * CALL ZLASET( 'Full', LDA, N, CZERO, CZERO, A, LDA ) * * 3) Generate Banded Matrix using Givens rotations. * Also the special case of UUB=LLB=0 * * Compute Addressing constants to cover all * storage formats. Whether GE, HE, SY, GB, HB, or SB, * upper or lower triangle or both, * the (i,j)-th element is in * A( i - ISKEW*j + IOFFST, j ) * IF( IPACK.GT.4 ) THEN ILDA = LDA - 1 ISKEW = 1 IF( IPACK.GT.5 ) THEN IOFFST = UUB + 1 ELSE IOFFST = 1 END IF ELSE ILDA = LDA ISKEW = 0 IOFFST = 0 END IF * * IPACKG is the format that the matrix is generated in. If this is * different from IPACK, then the matrix must be repacked at the * end. It also signals how to compute the norm, for scaling. * IPACKG = 0 * * Diagonal Matrix -- We are done, unless it * is to be stored HP/SP/PP/TP (PACK='R' or 'C') * IF( LLB.EQ.0 .AND. UUB.EQ.0 ) THEN DO 30 J = 1, MNMIN A( ( 1-ISKEW )*J+IOFFST, J ) = DCMPLX( D( J ) ) 30 CONTINUE * IF( IPACK.LE.2 .OR. IPACK.GE.5 ) $ IPACKG = IPACK * ELSE IF( GIVENS ) THEN * * Check whether to use Givens rotations, * Householder transformations, or nothing. * IF( ISYM.EQ.1 ) THEN * * Non-symmetric -- A = U D V * IF( IPACK.GT.4 ) THEN IPACKG = IPACK ELSE IPACKG = 0 END IF * DO 40 J = 1, MNMIN A( ( 1-ISKEW )*J+IOFFST, J ) = DCMPLX( D( J ) ) 40 CONTINUE * IF( TOPDWN ) THEN JKL = 0 DO 70 JKU = 1, UUB * * Transform from bandwidth JKL, JKU-1 to JKL, JKU * * Last row actually rotated is M * Last column actually rotated is MIN( M+JKU, N ) * DO 60 JR = 1, MIN( M+JKU, N ) + JKL - 1 EXTRA = CZERO ANGLE = TWOPI*DLARND( 1, ISEED ) C = COS( ANGLE )*ZLARND( 5, ISEED ) S = SIN( ANGLE )*ZLARND( 5, ISEED ) ICOL = MAX( 1, JR-JKL ) IF( JR.LT.M ) THEN IL = MIN( N, JR+JKU ) + 1 - ICOL CALL ZLAROT( .TRUE., JR.GT.JKL, .FALSE., IL, C, $ S, A( JR-ISKEW*ICOL+IOFFST, ICOL ), $ ILDA, EXTRA, DUMMY ) END IF * * Chase "EXTRA" back up * IR = JR IC = ICOL DO 50 JCH = JR - JKL, 1, -JKL - JKU IF( IR.LT.M ) THEN CALL ZLARTG( A( IR+1-ISKEW*( IC+1 )+IOFFST, $ IC+1 ), EXTRA, REALC, S, DUMMY ) DUMMY = ZLARND( 5, ISEED ) C = DCONJG( REALC*DUMMY ) S = DCONJG( -S*DUMMY ) END IF IROW = MAX( 1, JCH-JKU ) IL = IR + 2 - IROW CTEMP = CZERO ILTEMP = JCH.GT.JKU CALL ZLAROT( .FALSE., ILTEMP, .TRUE., IL, C, S, $ A( IROW-ISKEW*IC+IOFFST, IC ), $ ILDA, CTEMP, EXTRA ) IF( ILTEMP ) THEN CALL ZLARTG( A( IROW+1-ISKEW*( IC+1 )+IOFFST, $ IC+1 ), CTEMP, REALC, S, DUMMY ) DUMMY = ZLARND( 5, ISEED ) C = DCONJG( REALC*DUMMY ) S = DCONJG( -S*DUMMY ) * ICOL = MAX( 1, JCH-JKU-JKL ) IL = IC + 2 - ICOL EXTRA = CZERO CALL ZLAROT( .TRUE., JCH.GT.JKU+JKL, .TRUE., $ IL, C, S, A( IROW-ISKEW*ICOL+ $ IOFFST, ICOL ), ILDA, EXTRA, $ CTEMP ) IC = ICOL IR = IROW END IF 50 CONTINUE 60 CONTINUE 70 CONTINUE * JKU = UUB DO 100 JKL = 1, LLB * * Transform from bandwidth JKL-1, JKU to JKL, JKU * DO 90 JC = 1, MIN( N+JKL, M ) + JKU - 1 EXTRA = CZERO ANGLE = TWOPI*DLARND( 1, ISEED ) C = COS( ANGLE )*ZLARND( 5, ISEED ) S = SIN( ANGLE )*ZLARND( 5, ISEED ) IROW = MAX( 1, JC-JKU ) IF( JC.LT.N ) THEN IL = MIN( M, JC+JKL ) + 1 - IROW CALL ZLAROT( .FALSE., JC.GT.JKU, .FALSE., IL, C, $ S, A( IROW-ISKEW*JC+IOFFST, JC ), $ ILDA, EXTRA, DUMMY ) END IF * * Chase "EXTRA" back up * IC = JC IR = IROW DO 80 JCH = JC - JKU, 1, -JKL - JKU IF( IC.LT.N ) THEN CALL ZLARTG( A( IR+1-ISKEW*( IC+1 )+IOFFST, $ IC+1 ), EXTRA, REALC, S, DUMMY ) DUMMY = ZLARND( 5, ISEED ) C = DCONJG( REALC*DUMMY ) S = DCONJG( -S*DUMMY ) END IF ICOL = MAX( 1, JCH-JKL ) IL = IC + 2 - ICOL CTEMP = CZERO ILTEMP = JCH.GT.JKL CALL ZLAROT( .TRUE., ILTEMP, .TRUE., IL, C, S, $ A( IR-ISKEW*ICOL+IOFFST, ICOL ), $ ILDA, CTEMP, EXTRA ) IF( ILTEMP ) THEN CALL ZLARTG( A( IR+1-ISKEW*( ICOL+1 )+IOFFST, $ ICOL+1 ), CTEMP, REALC, S, $ DUMMY ) DUMMY = ZLARND( 5, ISEED ) C = DCONJG( REALC*DUMMY ) S = DCONJG( -S*DUMMY ) IROW = MAX( 1, JCH-JKL-JKU ) IL = IR + 2 - IROW EXTRA = CZERO CALL ZLAROT( .FALSE., JCH.GT.JKL+JKU, .TRUE., $ IL, C, S, A( IROW-ISKEW*ICOL+ $ IOFFST, ICOL ), ILDA, EXTRA, $ CTEMP ) IC = ICOL IR = IROW END IF 80 CONTINUE 90 CONTINUE 100 CONTINUE * ELSE * * Bottom-Up -- Start at the bottom right. * JKL = 0 DO 130 JKU = 1, UUB * * Transform from bandwidth JKL, JKU-1 to JKL, JKU * * First row actually rotated is M * First column actually rotated is MIN( M+JKU, N ) * IENDCH = MIN( M, N+JKL ) - 1 DO 120 JC = MIN( M+JKU, N ) - 1, 1 - JKL, -1 EXTRA = CZERO ANGLE = TWOPI*DLARND( 1, ISEED ) C = COS( ANGLE )*ZLARND( 5, ISEED ) S = SIN( ANGLE )*ZLARND( 5, ISEED ) IROW = MAX( 1, JC-JKU+1 ) IF( JC.GT.0 ) THEN IL = MIN( M, JC+JKL+1 ) + 1 - IROW CALL ZLAROT( .FALSE., .FALSE., JC+JKL.LT.M, IL, $ C, S, A( IROW-ISKEW*JC+IOFFST, $ JC ), ILDA, DUMMY, EXTRA ) END IF * * Chase "EXTRA" back down * IC = JC DO 110 JCH = JC + JKL, IENDCH, JKL + JKU ILEXTR = IC.GT.0 IF( ILEXTR ) THEN CALL ZLARTG( A( JCH-ISKEW*IC+IOFFST, IC ), $ EXTRA, REALC, S, DUMMY ) DUMMY = ZLARND( 5, ISEED )