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 ) 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 ZLAROT( .TRUE., ILEXTR, ILTEMP, ICOL+2-IC, $ C, S, A( JCH-ISKEW*IC+IOFFST, IC ), $ ILDA, EXTRA, CTEMP ) IF( ILTEMP ) THEN CALL ZLARTG( A( JCH-ISKEW*ICOL+IOFFST, $ ICOL ), CTEMP, REALC, S, DUMMY ) DUMMY = ZLARND( 5, ISEED ) C = REALC*DUMMY S = S*DUMMY IL = MIN( IENDCH, JCH+JKL+JKU ) + 2 - JCH EXTRA = CZERO CALL ZLAROT( .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*DLARND( 1, ISEED ) C = COS( ANGLE )*ZLARND( 5, ISEED ) S = SIN( ANGLE )*ZLARND( 5, ISEED ) ICOL = MAX( 1, JR-JKL+1 ) IF( JR.GT.0 ) THEN IL = MIN( N, JR+JKU+1 ) + 1 - ICOL CALL ZLAROT( .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 ZLARTG( A( IR-ISKEW*JCH+IOFFST, JCH ), $ EXTRA, REALC, S, DUMMY ) DUMMY = ZLARND( 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 ZLAROT( .FALSE., ILEXTR, ILTEMP, IROW+2-IR, $ C, S, A( IR-ISKEW*JCH+IOFFST, $ JCH ), ILDA, EXTRA, CTEMP ) IF( ILTEMP ) THEN CALL ZLARTG( A( IROW-ISKEW*JCH+IOFFST, JCH ), $ CTEMP, REALC, S, DUMMY ) DUMMY = ZLARND( 5, ISEED ) C = REALC*DUMMY S = S*DUMMY IL = MIN( IENDCH, JCH+JKL+JKU ) + 2 - JCH EXTRA = CZERO CALL ZLAROT( .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 ) = DCMPLX( 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*DLARND( 1, ISEED ) C = COS( ANGLE )*ZLARND( 5, ISEED ) S = SIN( ANGLE )*ZLARND( 5, ISEED ) IF( ZSYM ) THEN CT = C ST = S ELSE CTEMP = DCONJG( CTEMP ) CT = DCONJG( C ) ST = DCONJG( S ) END IF CALL ZLAROT( .FALSE., JC.GT.K, .TRUE., IL, C, S, $ A( IROW-ISKEW*JC+IOFFG, JC ), ILDA, $ EXTRA, CTEMP ) CALL ZLAROT( .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 ZLARTG( A( JCH+1-ISKEW*( ICOL+1 )+IOFFG, $ ICOL+1 ), EXTRA, REALC, S, DUMMY ) DUMMY = ZLARND( 5, ISEED ) C = DCONJG( REALC*DUMMY ) S = DCONJG( -S*DUMMY ) CTEMP = A( JCH-ISKEW*( JCH+1 )+IOFFG, JCH+1 ) IF( ZSYM ) THEN CT = C ST = S ELSE CTEMP = DCONJG( CTEMP ) CT = DCONJG( C ) ST = DCONJG( S ) END IF CALL ZLAROT( .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 ZLAROT( .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( ZSYM ) 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 ) = DCONJG( 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 ) = DCMPLX( 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*DLARND( 1, ISEED ) C = COS( ANGLE )*ZLARND( 5, ISEED ) S = SIN( ANGLE )*ZLARND( 5, ISEED ) IF( ZSYM ) THEN CT = C ST = S ELSE CTEMP = DCONJG( CTEMP ) CT = DCONJG( C ) ST = DCONJG( S ) END IF CALL ZLAROT( .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 ZLAROT( .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 ZLARTG( A( JCH-ISKEW*ICOL+IOFFG, ICOL ), $ EXTRA, REALC, S, DUMMY ) DUMMY = ZLARND( 5, ISEED ) C = REALC*DUMMY S = S*DUMMY CTEMP = A( 1+( 1-ISKEW )*JCH+IOFFG, JCH ) IF( ZSYM ) THEN CT = C ST = S ELSE CTEMP = DCONJG( CTEMP ) CT = DCONJG( C ) ST = DCONJG( S ) END IF CALL ZLAROT( .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 ZLAROT( .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( ZSYM ) 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 ) = DCONJG( 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.ZSYM ) THEN DO 350 JC = 1, N IROW = IOFFST + ( 1-ISKEW )*JC A( IROW, JC ) = DCMPLX( DBLE( 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 ZLAGGE( MR, NC, LLB, UUB, D, A, LDA, ISEED, WORK, $ IINFO ) ELSE * * Symmetric -- A = U D U' or * Hermitian -- A = U D U* * IF( ZSYM ) THEN CALL ZLAGSY( M, LLB, D, A, LDA, ISEED, WORK, IINFO ) ELSE CALL ZLAGHE( 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 ZLATMS * END SHAR_EOF fi # end of overwriting check cd .. if test ! -d 'testing' then mkdir 'testing' fi cd 'testing' if test -f 'ctest.lg.in' then echo shar: will not over-write existing file "'ctest.lg.in'" else cat << SHAR_EOF > 'ctest.lg.in' Data file for testing COMPLEX LAPACK linear eqn. routines 2 Number of values of M 200 500 Values of M (row dimension) 2 Number of values of N 200 500 Values of N (column dimension) 3 Number of values of NB 1 16 32 Values of NB (the blocksize) 1 0 0 Values of NX (crossover point) 30.0 Threshold value of test ratio T Put T to test the LAPACK routines T Put T to test the error exits CQP 6 List types on next line if 0 < NTYPES < 6 CRR 3 List types on next line if 0 < NTYPES < 3 SHAR_EOF fi # end of overwriting check if test -f 'ctest.me.in' then echo shar: will not over-write existing file "'ctest.me.in'" else cat << SHAR_EOF > 'ctest.me.in' Data file for testing COMPLEX LAPACK linear eqn. routines 2 Number of values of M 50 100 Values of M (row dimension) 2 Number of values of N 50 100 Values of N (column dimension) 3 Number of values of NB 1 16 32 Values of NB (the blocksize) 1 0 0 Values of NX (crossover point) 30.0 Threshold value of test ratio T Put T to test the LAPACK routines T Put T to test the error exits CQP 6 List types on next line if 0 < NTYPES < 6 CRR 3 List types on next line if 0 < NTYPES < 3 SHAR_EOF fi # end of overwriting check if test -f 'ctest.sm.in' then echo shar: will not over-write existing file "'ctest.sm.in'" else cat << SHAR_EOF > 'ctest.sm.in' Data file for testing COMPLEX LAPACK linear eqn. routines 7 Number of values of M 0 1 2 3 5 10 16 Values of M (row dimension) 7 Number of values of N 0 1 2 3 5 10 16 Values of N (column dimension) 5 Number of values of NB 1 3 3 3 20 Values of NB (the blocksize) 1 0 5 9 1 Values of NX (crossover point) 30.0 Threshold value of test ratio T Put T to test the LAPACK routines T Put T to test the error exits CQP 6 List types on next line if 0 < NTYPES < 6 CRR 3 List types on next line if 0 < NTYPES < 3 SHAR_EOF fi # end of overwriting check if test -f 'dtest.lg.in' then echo shar: will not over-write existing file "'dtest.lg.in'" else cat << SHAR_EOF > 'dtest.lg.in' Data file for testing DOUBLE PRECISION LAPACK linear eqn. routines 2 Number of values of M 200 500 Values of M (row dimension) 2 Number of values of N 200 500 Values of N (column dimension) 3 Number of values of NB 1 16 32 Values of NB (the blocksize) 1 0 0 Values of NX (crossover point) 30.0 Threshold value of test ratio T Put T to test the LAPACK routines T Put T to test the error exits DQP 6 List types on next line if 0 < NTYPES < 6 DRR 3 List types on next line if 0 < NTYPES < 3 SHAR_EOF fi # end of overwriting check if test -f 'dtest.me.in' then echo shar: will not over-write existing file "'dtest.me.in'" else cat << SHAR_EOF > 'dtest.me.in' Data file for testing DOUBLE PRECISION LAPACK linear eqn. routines 2 Number of values of M 50 100 Values of M (row dimension) 2 Number of values of N 50 100 Values of N (column dimension) 3 Number of values of NB 1 16 32 Values of NB (the blocksize) 1 0 0 Values of NX (crossover point) 30.0 Threshold value of test ratio T Put T to test the LAPACK routines T Put T to test the error exits DQP 6 List types on next line if 0 < NTYPES < 6 DRR 3 List types on next line if 0 < NTYPES < 3 SHAR_EOF fi # end of overwriting check if test -f 'dtest.sm.in' then echo shar: will not over-write existing file "'dtest.sm.in'" else cat << SHAR_EOF > 'dtest.sm.in' Data file for testing DOUBLE PRECISION LAPACK linear eqn. routines 7 Number of values of M 0 1 2 3 5 10 16 Values of M (row dimension) 7 Number of values of N 0 1 2 3 5 10 16 Values of N (column dimension) 5 Number of values of NB 1 3 3 3 20 Values of NB (the blocksize) 1 0 5 9 1 Values of NX (crossover point) 30.0 Threshold value of test ratio T Put T to test the LAPACK routines T Put T to test the error exits DQP 6 List types on next line if 0 < NTYPES < 6 DRR 3 List types on next line if 0 < NTYPES < 3 SHAR_EOF fi # end of overwriting check if test -f 'stest.lg.in' then echo shar: will not over-write existing file "'stest.lg.in'" else cat << SHAR_EOF > 'stest.lg.in' Data file for testing REAL LAPACK linear eqn. routines 2 Number of values of M 200 500 Values of M (row dimension) 2 Number of values of N 200 500 Values of N (column dimension) 3 Number of values of NB 1 16 32 Values of NB (the blocksize) 1 0 0 Values of NX (crossover point) 30.0 Threshold value of test ratio T Put T to test the LAPACK routines T Put T to test the error exits SQP 6 List types on next line if 0 < NTYPES < 6 SRR 3 List types on next line if 0 < NTYPES < 3 SHAR_EOF fi # end of overwriting check if test -f 'stest.me.in' then echo shar: will not over-write existing file "'stest.me.in'" else cat << SHAR_EOF > 'stest.me.in' Data file for testing REAL LAPACK linear eqn. routines 2 Number of values of M 50 100 Values of M (row dimension) 2 Number of values of N 50 100 Values of N (column dimension) 3 Number of values of NB 1 16 32 Values of NB (the blocksize) 1 0 0 Values of NX (crossover point) 30.0 Threshold value of test ratio T Put T to test the LAPACK routines T Put T to test the error exits SQP 6 List types on next line if 0 < NTYPES < 6 SRR 3 List types on next line if 0 < NTYPES < 3 SHAR_EOF fi # end of overwriting check if test -f 'stest.sm.in' then echo shar: will not over-write existing file "'stest.sm.in'" else cat << SHAR_EOF > 'stest.sm.in' Data file for testing REAL LAPACK linear eqn. routines 7 Number of values of M 0 1 2 3 5 10 16 Values of M (row dimension) 7 Number of values of N 0 1 2 3 5 10 16 Values of N (column dimension) 5 Number of values of NB 1 3 3 3 20 Values of NB (the blocksize) 1 0 5 9 1 Values of NX (crossover point) 30.0 Threshold value of test ratio T Put T to test the LAPACK routines T Put T to test the error exits SQP 6 List types on next line if 0 < NTYPES < 6 SRR 3 List types on next line if 0 < NTYPES < 3 SHAR_EOF fi # end of overwriting check if test -f 'testall' then echo shar: will not over-write existing file "'testall'" else cat << SHAR_EOF > 'testall' xlintsts < stest.sm.in > stest.sm.out xlintstd < dtest.sm.in > dtest.sm.out xlintstc < ctest.sm.in > ctest.sm.out xlintstz < ztest.sm.in > ztest.sm.out xlintsts < stest.me.in > stest.me.out xlintstd < dtest.me.in > dtest.me.out xlintstc < ctest.me.in > ctest.me.out xlintstz < ztest.me.in > ztest.me.out xlintsts < stest.lg.in > stest.lg.out xlintstd < dtest.lg.in > dtest.lg.out xlintstc < ctest.lg.in > ctest.lg.out xlintstz < ztest.lg.in > ztest.lg.out echo "End of testall" SHAR_EOF fi # end of overwriting check if test -f 'testall.lg' then echo shar: will not over-write existing file "'testall.lg'" else cat << SHAR_EOF > 'testall.lg' xlintsts < stest.lg.in > stest.lg.out xlintstd < dtest.lg.in > dtest.lg.out xlintstc < ctest.lg.in > ctest.lg.out xlintstz < ztest.lg.in > ztest.lg.out echo "End of testall.lg" SHAR_EOF fi # end of overwriting check if test -f 'testall.me' then echo shar: will not over-write existing file "'testall.me'" else cat << SHAR_EOF > 'testall.me' xlintsts < stest.me.in > stest.me.out xlintstd < dtest.me.in > dtest.me.out xlintstc < ctest.me.in > ctest.me.out xlintstz < ztest.me.in > ztest.me.out echo "End of testall.me" SHAR_EOF fi # end of overwriting check if test -f 'testall.sm' then echo shar: will not over-write existing file "'testall.sm'" else cat << SHAR_EOF > 'testall.sm' xlintsts < stest.sm.in > stest.sm.out xlintstd < dtest.sm.in > dtest.sm.out xlintstc < ctest.sm.in > ctest.sm.out xlintstz < ztest.sm.in > ztest.sm.out echo "End of testall.sm" SHAR_EOF fi # end of overwriting check if test ! -d 'v2' then mkdir 'v2' fi cd 'v2' if test -f 'GenCode' then echo shar: will not over-write existing file "'GenCode'" else cat << SHAR_EOF > 'GenCode' cp ../../../testing/v2/*.f . make source -f Makefile.GenCode SHAR_EOF fi # end of overwriting check 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 = /opt/fortran/bin/f77 OPTS = -u -g -C #-dalign LOADER = /opt/fortran/bin/f77 LOADOPTS = -g -C +U77 #-dalign LAPACKLIB = -llapack-2 #/usr/local/lib/lapack/lapack.a TMGLIB = -ltmglib-2 #/usr/local/lib/lapack/tmglib.a BLASLIB = /opt/fortran/lib/pa1.1/libblas.a #/usr/local/lib/lapack/blas.f77.a # On the SUN Solaris, it is recommended: #FORTRAN = f77 #OPTS = -u -O -dalign #LOADER = f77 #LOADOPTS = -O -dalign #LAPACKLIB = #TMGLIB = /usr/local/lapack/tmglib.a #BLASLIB = /home1/SUNWspro/SC3.0.1/lib/libsunperf.a # On the IBM RS6K, it is recommended: #FORTRAN = xlf #OPTS = -u -O3 #LOADER = xlf #LOADOPTS = -O3 -bnso -bI:/lib/syscalls.exp # #LAPACKLIB = /usr/local/lapack/lib/lapack.a #TMGLIB = /usr/local/lapack/lib/tmglib.a #BLASLIB = -lblas # ####################################################################### # No more changes are required beyond this line. ####################################################################### # Special modules # RRQRLIB = ../../rrqr.a SHELL = /bin/csh ALINTST = \ aladhd.o alaerh.o alaesm.o alahd.o alareq.o \ alasum.o alasvm.o chkxer.o ilaenv.o xlaenv.o xerbla.o SCLNTST= \ slaord.o DZLNTST= \ dlaord.o SLINTST = schkaa.o schkqp.o schkrr.o \ serrqp.o serrrr.o sqpt01.o sqrt11.o sqrt12.o srrt01.o srrt02.o CLINTST = cchkaa.o cchkqp.o cchkrr.o \ cerrqp.o cerrrr.o cqpt01.o cqrt11.o cqrt12.o crrt01.o crrt02.o DLINTST = dchkaa.o dchkqp.o dchkrr.o \ derrqp.o derrrr.o dqpt01.o dqrt11.o dqrt12.o drrt01.o drrt02.o ZLINTST = zchkaa.o zchkqp.o zchkrr.o \ zerrqp.o zerrrr.o zqpt01.o zqrt11.o zqrt12.o zrrt01.o zrrt02.o all: single double complex complex16 single: ../xlintsts double: ../xlintstd complex: ../xlintstc complex16: ../xlintstz ../xlintsts : $(ALINTST) $(SLINTST) $(SCLNTST) $(LOADER) $(LOADOPTS) $(ALINTST) $(SCLNTST) $(SLINTST) \ $(RRQRLIB) $(TMGLIB) $(LAPACKLIB) $(BLASLIB) -o $@ ../xlintstc : $(ALINTST) $(CLINTST) $(SCLNTST) $(LOADER) $(LOADOPTS) $(ALINTST) $(SCLNTST) $(CLINTST) \ $(RRQRLIB) $(TMGLIB) $(LAPACKLIB) $(BLASLIB) -o $@ ../xlintstd : $(ALINTST) $(DLINTST) $(DZLNTST) $(LOADER) $(LOADOPTS) $(ALINTST) $(DZLNTST) $(DLINTST) \ $(RRQRLIB) $(TMGLIB) $(LAPACKLIB) $(BLASLIB) -o $@ ../xlintstz : $(ALINTST) $(ZLINTST) $(DZLNTST) $(LOADER) $(LOADOPTS) $(ALINTST) $(DZLNTST) $(ZLINTST) \ $(RRQRLIB) $(TMGLIB) $(LAPACKLIB) $(BLASLIB) -o $@ # # Rules for the modules. # .f.o: $(FORTRAN) -c $(OPTS) $*.f # # Clean rule. # clean: - rm -f *.o ../xlintst? 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 testing codes. # CPP = /lib/cpp CPPFLAGS = "" REAL_SOURCES = ../../../v15 GENERATE = $(REAL_SOURCES)/generate TESTING_SOURCES = ../../../testing/v2 # ####################################################################### ####################################################################### # S_TESTING_MODULES = \ schkaa.f schkrr.f serrrr.f srrt01.f srrt02.f D_TESTING_MODULES = \ dchkaa.f dchkrr.f derrrr.f drrt01.f drrt02.f C_TESTING_MODULES = \ cchkaa.f cchkrr.f cerrrr.f crrt01.f crrt02.f Z_TESTING_MODULES = \ zchkaa.f zchkrr.f zerrrr.f zrrt01.f zrrt02.f source: single double complex complex16 single: $(S_TESTING_MODULES) double: $(D_TESTING_MODULES) complex: $(C_TESTING_MODULES) complex16: $(Z_TESTING_MODULES) # # Rules for the checking modules affected by the modifications # in new Single Precision xGERQR. # schkaa.f: $(TESTING_SOURCES)/xchkaa.F $(GENERATE) s $(TESTING_SOURCES)/xchkaa.F schkaa.f $(CPP) $(CPPFLAGS) schkrr.f: $(TESTING_SOURCES)/xchkrr.F $(GENERATE) s $(TESTING_SOURCES)/xchkrr.F schkrr.f $(CPP) $(CPPFLAGS) serrrr.f: $(TESTING_SOURCES)/xerrrr.F $(GENERATE) s $(TESTING_SOURCES)/xerrrr.F serrrr.f $(CPP) $(CPPFLAGS) srrt01.f: $(TESTING_SOURCES)/xrrt01.F $(GENERATE) s $(TESTING_SOURCES)/xrrt01.F srrt01.f $(CPP) $(CPPFLAGS) srrt02.f: $(TESTING_SOURCES)/xrrt02.F $(GENERATE) s $(TESTING_SOURCES)/xrrt02.F srrt02.f $(CPP) $(CPPFLAGS) # # Rules for the checking modules affected by the modifications # in new Double Precision xGERQR. # dchkaa.f: $(TESTING_SOURCES)/xchkaa.F $(GENERATE) d $(TESTING_SOURCES)/xchkaa.F dchkaa.f $(CPP) $(CPPFLAGS) dchkrr.f: $(TESTING_SOURCES)/xchkrr.F $(GENERATE) d $(TESTING_SOURCES)/xchkrr.F dchkrr.f $(CPP) $(CPPFLAGS) derrrr.f: $(TESTING_SOURCES)/xerrrr.F $(GENERATE) d $(TESTING_SOURCES)/xerrrr.F derrrr.f $(CPP) $(CPPFLAGS) drrt01.f: $(TESTING_SOURCES)/xrrt01.F $(GENERATE) d $(TESTING_SOURCES)/xrrt01.F drrt01.f $(CPP) $(CPPFLAGS) drrt02.f: $(TESTING_SOURCES)/xrrt02.F $(GENERATE) d $(TESTING_SOURCES)/xrrt02.F drrt02.f $(CPP) $(CPPFLAGS) # # Rules for the checking modules affected by the modifications # in new Complex yGERQR. # cchkaa.f: $(TESTING_SOURCES)/ychkaa.F $(GENERATE) c $(TESTING_SOURCES)/ychkaa.F cchkaa.f $(CPP) $(CPPFLAGS) cchkrr.f: $(TESTING_SOURCES)/ychkrr.F $(GENERATE) c $(TESTING_SOURCES)/ychkrr.F cchkrr.f $(CPP) $(CPPFLAGS) cerrrr.f: $(TESTING_SOURCES)/yerrrr.F $(GENERATE) c $(TESTING_SOURCES)/yerrrr.F cerrrr.f $(CPP) $(CPPFLAGS) crrt01.f: $(TESTING_SOURCES)/yrrt01.F $(GENERATE) c $(TESTING_SOURCES)/yrrt01.F crrt01.f $(CPP) $(CPPFLAGS) crrt02.f: $(TESTING_SOURCES)/yrrt02.F $(GENERATE) c $(TESTING_SOURCES)/yrrt02.F crrt02.f $(CPP) $(CPPFLAGS) # # Rules for the checking modules affected by the modifications # in new Complex*16 yGERQR. # zchkaa.f: $(TESTING_SOURCES)/ychkaa.F $(GENERATE) z $(TESTING_SOURCES)/ychkaa.F zchkaa.f $(CPP) $(CPPFLAGS) zchkrr.f: $(TESTING_SOURCES)/ychkrr.F $(GENERATE) z $(TESTING_SOURCES)/ychkrr.F zchkrr.f $(CPP) $(CPPFLAGS) zerrrr.f: $(TESTING_SOURCES)/yerrrr.F $(GENERATE) z $(TESTING_SOURCES)/yerrrr.F zerrrr.f $(CPP) $(CPPFLAGS) zrrt01.f: $(TESTING_SOURCES)/yrrt01.F $(GENERATE) z $(TESTING_SOURCES)/yrrt01.F zrrt01.f $(CPP) $(CPPFLAGS) zrrt02.f: $(TESTING_SOURCES)/yrrt02.F $(GENERATE) z $(TESTING_SOURCES)/yrrt02.F zrrt02.f $(CPP) $(CPPFLAGS) # # Clean rule. # clean: - rm -f *.o *.f *.F SHAR_EOF fi # end of overwriting check if test -f 'aladhd.f' then echo shar: will not over-write existing file "'aladhd.f'" else cat << SHAR_EOF > 'aladhd.f' SUBROUTINE ALADHD( IOUNIT, PATH ) * * -- 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*3 PATH INTEGER IOUNIT * .. * * Purpose * ======= * * ALADHD prints header information for the driver routines test paths. * * Arguments * ========= * * IOUNIT (input) INTEGER * The unit number to which the header information should be * printed. * * PATH (input) CHARACTER*3 * The name of the path for which the header information is to * be printed. Current paths are * _GE: General matrices * _GB: General band * _GT: General Tridiagonal * _PO: Symmetric or Hermitian positive definite * _PP: Symmetric or Hermitian positive definite packed * _PB: Symmetric or Hermitian positive definite band * _PT: Symmetric or Hermitian positive definite tridiagonal * _SY: Symmetric indefinite * _SP: Symmetric indefinite packed * _HE: (complex) Hermitian indefinite * _HP: (complex) Hermitian indefinite packed * The first character must be one of S, D, C, or Z (C or Z only * if complex). * * .. Local Scalars .. LOGICAL CORZ, SORD CHARACTER C1, C3 CHARACTER*2 P2 CHARACTER*9 SYM * .. * .. External Functions .. LOGICAL LSAME, LSAMEN EXTERNAL LSAME, LSAMEN * .. * .. Executable Statements .. * IF( IOUNIT.LE.0 ) $ RETURN C1 = PATH( 1: 1 ) C3 = PATH( 3: 3 ) P2 = PATH( 2: 3 ) SORD = LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' ) CORZ = LSAME( C1, 'C' ) .OR. LSAME( C1, 'Z' ) IF( .NOT.( SORD .OR. CORZ ) ) $ RETURN * IF( LSAMEN( 2, P2, 'GE' ) ) THEN * * GE: General dense * WRITE( IOUNIT, FMT = 9999 )PATH WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' ) WRITE( IOUNIT, FMT = 9989 ) WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) WRITE( IOUNIT, FMT = 9981 )1 WRITE( IOUNIT, FMT = 9980 )2 WRITE( IOUNIT, FMT = 9979 )3 WRITE( IOUNIT, FMT = 9978 )4 WRITE( IOUNIT, FMT = 9977 )5 WRITE( IOUNIT, FMT = 9976 )6 WRITE( IOUNIT, FMT = 9972 )7 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * ELSE IF( LSAMEN( 2, P2, 'GB' ) ) THEN * * GB: General band * WRITE( IOUNIT, FMT = 9998 )PATH WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' ) WRITE( IOUNIT, FMT = 9988 ) WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) WRITE( IOUNIT, FMT = 9981 )1 WRITE( IOUNIT, FMT = 9980 )2 WRITE( IOUNIT, FMT = 9979 )3 WRITE( IOUNIT, FMT = 9978 )4 WRITE( IOUNIT, FMT = 9977 )5 WRITE( IOUNIT, FMT = 9976 )6 WRITE( IOUNIT, FMT = 9972 )7 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * ELSE IF( LSAMEN( 2, P2, 'GT' ) ) THEN * * GT: General tridiagonal * WRITE( IOUNIT, FMT = 9997 )PATH WRITE( IOUNIT, FMT = 9987 ) WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) WRITE( IOUNIT, FMT = 9981 )1 WRITE( IOUNIT, FMT = 9980 )2 WRITE( IOUNIT, FMT = 9979 )3 WRITE( IOUNIT, FMT = 9978 )4 WRITE( IOUNIT, FMT = 9977 )5 WRITE( IOUNIT, FMT = 9976 )6 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * ELSE IF( LSAMEN( 2, P2, 'PO' ) .OR. LSAMEN( 2, P2, 'PP' ) ) THEN * * PO: Positive definite full * PP: Positive definite packed * IF( SORD ) THEN SYM = 'Symmetric' ELSE SYM = 'Hermitian' END IF IF( LSAME( C3, 'O' ) ) THEN WRITE( IOUNIT, FMT = 9996 )PATH, SYM ELSE WRITE( IOUNIT, FMT = 9995 )PATH, SYM END IF WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' ) WRITE( IOUNIT, FMT = 9985 )PATH WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) WRITE( IOUNIT, FMT = 9975 )1 WRITE( IOUNIT, FMT = 9980 )2 WRITE( IOUNIT, FMT = 9979 )3 WRITE( IOUNIT, FMT = 9978 )4 WRITE( IOUNIT, FMT = 9977 )5 WRITE( IOUNIT, FMT = 9976 )6 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * ELSE IF( LSAMEN( 2, P2, 'PB' ) ) THEN * * PB: Positive definite band * IF( SORD ) THEN WRITE( IOUNIT, FMT = 9994 )PATH, 'Symmetric' ELSE WRITE( IOUNIT, FMT = 9994 )PATH, 'Hermitian' END IF WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' ) WRITE( IOUNIT, FMT = 9984 )PATH WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) WRITE( IOUNIT, FMT = 9975 )1 WRITE( IOUNIT, FMT = 9980 )2 WRITE( IOUNIT, FMT = 9979 )3 WRITE( IOUNIT, FMT = 9978 )4 WRITE( IOUNIT, FMT = 9977 )5 WRITE( IOUNIT, FMT = 9976 )6 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * ELSE IF( LSAMEN( 2, P2, 'PT' ) ) THEN * * PT: Positive definite tridiagonal * IF( SORD ) THEN WRITE( IOUNIT, FMT = 9993 )PATH, 'Symmetric' ELSE WRITE( IOUNIT, FMT = 9993 )PATH, 'Hermitian' END IF WRITE( IOUNIT, FMT = 9986 ) WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) WRITE( IOUNIT, FMT = 9973 )1 WRITE( IOUNIT, FMT = 9980 )2 WRITE( IOUNIT, FMT = 9979 )3 WRITE( IOUNIT, FMT = 9978 )4 WRITE( IOUNIT, FMT = 9977 )5 WRITE( IOUNIT, FMT = 9976 )6 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * ELSE IF( LSAMEN( 2, P2, 'SY' ) .OR. LSAMEN( 2, P2, 'SP' ) ) THEN * * SY: Symmetric indefinite full * SP: Symmetric indefinite packed * IF( LSAME( C3, 'Y' ) ) THEN WRITE( IOUNIT, FMT = 9992 )PATH, 'Symmetric' ELSE WRITE( IOUNIT, FMT = 9991 )PATH, 'Symmetric' END IF WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' ) IF( SORD ) THEN WRITE( IOUNIT, FMT = 9983 ) ELSE WRITE( IOUNIT, FMT = 9982 ) END IF WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) WRITE( IOUNIT, FMT = 9974 )1 WRITE( IOUNIT, FMT = 9980 )2 WRITE( IOUNIT, FMT = 9979 )3 WRITE( IOUNIT, FMT = 9977 )4 WRITE( IOUNIT, FMT = 9978 )5 WRITE( IOUNIT, FMT = 9976 )6 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * ELSE IF( LSAMEN( 2, P2, 'HE' ) .OR. LSAMEN( 2, P2, 'HP' ) ) THEN * * HE: Hermitian indefinite full * HP: Hermitian indefinite packed * IF( LSAME( C3, 'E' ) ) THEN WRITE( IOUNIT, FMT = 9992 )PATH, 'Hermitian' ELSE WRITE( IOUNIT, FMT = 9991 )PATH, 'Hermitian' END IF WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' ) WRITE( IOUNIT, FMT = 9983 ) WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) WRITE( IOUNIT, FMT = 9974 )1 WRITE( IOUNIT, FMT = 9980 )2 WRITE( IOUNIT, FMT = 9979 )3 WRITE( IOUNIT, FMT = 9977 )4 WRITE( IOUNIT, FMT = 9978 )5 WRITE( IOUNIT, FMT = 9976 )6 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * ELSE * * Print error message if no header is available. * WRITE( IOUNIT, FMT = 9990 )PATH END IF * * First line of header * 9999 FORMAT( / 1X, A3, ' drivers: General dense matrices' ) 9998 FORMAT( / 1X, A3, ' drivers: General band matrices' ) 9997 FORMAT( / 1X, A3, ' drivers: General tridiagonal' ) 9996 FORMAT( / 1X, A3, ' drivers: ', A9, $ ' positive definite matrices' ) 9995 FORMAT( / 1X, A3, ' drivers: ', A9, $ ' positive definite packed matrices' ) 9994 FORMAT( / 1X, A3, ' drivers: ', A9, $ ' positive definite band matrices' ) 9993 FORMAT( / 1X, A3, ' drivers: ', A9, $ ' positive definite tridiagonal' ) 9992 FORMAT( / 1X, A3, ' drivers: ', A9, ' indefinite matrices' ) 9991 FORMAT( / 1X, A3, ' drivers: ', A9, $ ' indefinite packed matrices' ) 9990 FORMAT( / 1X, A3, ': No header available' ) * * GE matrix types * 9989 FORMAT( 4X, '1. Diagonal', 24X, '7. Last n/2 columns zero', / 4X, $ '2. Upper triangular', 16X, $ '8. Random, CNDNUM = sqrt(0.1/EPS)', / 4X, $ '3. Lower triangular', 16X, '9. Random, CNDNUM = 0.1/EPS', $ / 4X, '4. Random, CNDNUM = 2', 13X, $ '10. Scaled near underflow', / 4X, '5. First column zero', $ 14X, '11. Scaled near overflow', / 4X, $ '6. Last column zero' ) * * GB matrix types * 9988 FORMAT( 4X, '1. Random, CNDNUM = 2', 14X, $ '5. Random, CNDNUM = sqrt(0.1/EPS)', / 4X, $ '2. First column zero', 15X, '6. Random, CNDNUM = 0.1/EPS', $ / 4X, '3. Last column zero', 16X, $ '7. Scaled near underflow', / 4X, $ '4. Last n/2 columns zero', 11X, '8. Scaled near overflow' ) * * GT matrix types * 9987 FORMAT( ' Matrix types (1-6 have specified condition numbers):', $ / 4X, '1. Diagonal', 24X, '7. Random, unspecified CNDNUM', $ / 4X, '2. Random, CNDNUM = 2', 14X, '8. First column zero', $ / 4X, '3. Random, CNDNUM = sqrt(0.1/EPS)', 2X, $ '9. Last column zero', / 4X, '4. Random, CNDNUM = 0.1/EPS', $ 7X, '10. Last n/2 columns zero', / 4X, $ '5. Scaled near underflow', 10X, $ '11. Scaled near underflow', / 4X, $ '6. Scaled near overflow', 11X, '12. Scaled near overflow' ) * * PT matrix types * 9986 FORMAT( ' Matrix types (1-6 have specified condition numbers):', $ / 4X, '1. Diagonal', 24X, '7. Random, unspecified CNDNUM', $ / 4X, '2. Random, CNDNUM = 2', 14X, $ '8. First row and column zero', / 4X, $ '3. Random, CNDNUM = sqrt(0.1/EPS)', 2X, $ '9. Last row and column zero', / 4X, $ '4. Random, CNDNUM = 0.1/EPS', 7X, $ '10. Middle row and column zero', / 4X, $ '5. Scaled near underflow', 10X, $ '11. Scaled near underflow', / 4X, $ '6. Scaled near overflow', 11X, '12. Scaled near overflow' ) * * PO, PP matrix types * 9985 FORMAT( 4X, '1. Diagonal', 24X, $ '6. Random, CNDNUM = sqrt(0.1/EPS)', / 4X, $ '2. Random, CNDNUM = 2', 14X, '7. Random, CNDNUM = 0.1/EPS', $ / 3X, '*3. First row and column zero', 7X, $ '8. Scaled near underflow', / 3X, $ '*4. Last row and column zero', 8X, $ '9. Scaled near overflow', / 3X, $ '*5. Middle row and column zero', / 3X, $ '(* - tests error exits from ', A3, $ 'TRF, no test ratios are computed)' ) * * PB matrix types * 9984 FORMAT( 4X, '1. Random, CNDNUM = 2', 14X, $ '5. Random, CNDNUM = sqrt(0.1/EPS)', / 3X, $ '*2. First row and column zero', 7X, $ '6. Random, CNDNUM = 0.1/EPS', / 3X, $ '*3. Last row and column zero', 8X, $ '7. Scaled near underflow', / 3X, $ '*4. Middle row and column zero', 6X, $ '8. Scaled near overflow', / 3X, $ '(* - tests error exits from ', A3, $ 'TRF, no test ratios are computed)' ) * * SSY, SSP, CHE, CHP matrix types * 9983 FORMAT( 4X, '1. Diagonal', 24X, $ '6. Last n/2 rows and columns zero', / 4X, $ '2. Random, CNDNUM = 2', 14X, $ '7. Random, CNDNUM = sqrt(0.1/EPS)', / 4X, $ '3. First row and column zero', 7X, $ '8. Random, CNDNUM = 0.1/EPS', / 4X, $ '4. Last row and column zero', 8X, $ '9. Scaled near underflow', / 4X, $ '5. Middle row and column zero', 5X, $ '10. Scaled near overflow' ) * * CSY, CSP matrix types * 9982 FORMAT( 4X, '1. Diagonal', 24X, $ '7. Random, CNDNUM = sqrt(0.1/EPS)', / 4X, $ '2. Random, CNDNUM = 2', 14X, '8. Random, CNDNUM = 0.1/EPS', $ / 4X, '3. First row and column zero', 7X, $ '9. Scaled near underflow', / 4X, $ '4. Last row and column zero', 7X, $ '10. Scaled near overflow', / 4X, $ '5. Middle row and column zero', 5X, $ '11. Block diagonal matrix', / 4X, $ '6. Last n/2 rows and columns zero' ) * * Test ratios * 9981 FORMAT( 3X, I2, ': norm( L * U - A ) / ( N * norm(A) * EPS )' ) 9980 FORMAT( 3X, I2, ': norm( B - A * X ) / ', $ '( norm(A) * norm(X) * EPS )' ) 9979 FORMAT( 3X, I2, ': norm( X - XACT ) / ', $ '( norm(XACT) * CNDNUM * EPS )' ) 9978 FORMAT( 3X, I2, ': norm( X - XACT ) / ', $ '( norm(XACT) * (error bound) )' ) 9977 FORMAT( 3X, I2, ': (backward error) / EPS' ) 9976 FORMAT( 3X, I2, ': RCOND * CNDNUM - 1.0' ) 9975 FORMAT( 3X, I2, ': norm( U'' * U - A ) / ( N * norm(A) * EPS )', $ ', or', / 7X, 'norm( L * L'' - A ) / ( N * norm(A) * EPS )' $ ) 9974 FORMAT( 3X, I2, ': norm( U*D*U'' - A ) / ( N * norm(A) * EPS )', $ ', or', / 7X, 'norm( L*D*L'' - A ) / ( N * norm(A) * EPS )' $ ) 9973 FORMAT( 3X, I2, ': norm( U''*D*U - A ) / ( N * norm(A) * EPS )', $ ', or', / 7X, 'norm( L*D*L'' - A ) / ( N * norm(A) * EPS )' $ ) 9972 FORMAT( 3X, I2, ': abs( WORK(1) - RPVGRW ) /', $ ' ( max( WORK(1), RPVGRW ) * EPS )' ) * RETURN * * End of ALADHD * END SHAR_EOF fi # end of overwriting check if test -f 'alaerh.f' then echo shar: will not over-write existing file "'alaerh.f'" else cat << SHAR_EOF > 'alaerh.f' SUBROUTINE ALAERH( PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, $ N5, IMAT, NFAIL, NERRS, NOUT ) * * -- 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 .. CHARACTER*3 PATH CHARACTER*6 SUBNAM CHARACTER*( * ) OPTS INTEGER IMAT, INFO, INFOE, KL, KU, M, N, N5, NERRS, $ NFAIL, NOUT * .. * * Purpose * ======= * * ALAERH is an error handler for the LAPACK routines. It prints the * header if this is the first error message and prints the error code * and form of recovery, if any. The character evaluations in this * routine may make it slow, but it should not be called once the LAPACK * routines are fully debugged. * * Arguments * ========= * * PATH (input) CHARACTER*3 * The LAPACK path name of subroutine SUBNAM. * * SUBNAM (input) CHARACTER*6 * The name of the subroutine that returned an error code. * * INFO (input) INTEGER * The error code returned from routine SUBNAM. * * INFOE (input) INTEGER * The expected error code from routine SUBNAM, if SUBNAM were * error-free. If INFOE = 0, an error message is printed, but * if INFOE.NE.0, we assume only the return code INFO is wrong. * * OPTS (input) CHARACTER*(*) * The character options to the subroutine SUBNAM, concatenated * into a single character string. For example, UPLO = 'U', * TRANS = 'T', and DIAG = 'N' for a triangular routine would * be specified as OPTS = 'UTN'. * * M (input) INTEGER * The matrix row dimension. * * N (input) INTEGER * The matrix column dimension. Accessed only if PATH = xGE or * xGB. * * KL (input) INTEGER * The number of sub-diagonals of the matrix. Accessed only if * PATH = xGB, xPB, or xTB. Also used for NRHS for PATH = xLS. * * KU (input) INTEGER * The number of super-diagonals of the matrix. Accessed only * if PATH = xGB. * * N5 (input) INTEGER * A fifth integer parameter, may be the blocksize NB or the * number of right hand sides NRHS. * * IMAT (input) INTEGER * The matrix type. * * NFAIL (input) INTEGER * The number of prior tests that did not pass the threshold; * used to determine if the header should be printed. * * NERRS (input/output) INTEGER * On entry, the number of errors already detected; used to * determine if the header should be printed. * On exit, NERRS is increased by 1. * * NOUT (input) INTEGER * The unit number on which results are to be printed. * * ===================================================================== * * .. Local Scalars .. CHARACTER UPLO CHARACTER*2 P2 CHARACTER*3 C3 * .. * .. External Functions .. LOGICAL LSAME, LSAMEN EXTERNAL LSAME, LSAMEN * .. * .. External Subroutines .. EXTERNAL ALADHD, ALAHD * .. * .. Executable Statements .. * IF( INFO.EQ.0 ) $ RETURN P2 = PATH( 2: 3 ) C3 = SUBNAM( 4: 6 ) * * Print the header if this is the first error message. * IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) THEN IF( LSAMEN( 3, C3, 'SV ' ) .OR. LSAMEN( 3, C3, 'SVX' ) ) THEN CALL ALADHD( NOUT, PATH ) ELSE CALL ALAHD( NOUT, PATH ) END IF END IF NERRS = NERRS + 1 * * Print the message detailing the error and form of recovery, * if any. * IF( LSAMEN( 2, P2, 'GE' ) ) THEN * * xGE: General matrices * IF( LSAMEN( 3, C3, 'TRF' ) ) THEN IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9988 )SUBNAM, INFO, INFOE, M, N, N5, $ IMAT ELSE WRITE( NOUT, FMT = 9975 )SUBNAM, INFO, M, N, N5, IMAT END IF IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9949 ) * ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN * IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9984 )SUBNAM, INFO, INFOE, N, N5, $ IMAT ELSE WRITE( NOUT, FMT = 9970 )SUBNAM, INFO, N, N5, IMAT END IF * ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN * IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9992 )SUBNAM, INFO, INFOE, $ OPTS( 1: 1 ), OPTS( 2: 2 ), N, N5, IMAT ELSE WRITE( NOUT, FMT = 9997 )SUBNAM, INFO, OPTS( 1: 1 ), $ OPTS( 2: 2 ), N, N5, IMAT END IF * ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN * WRITE( NOUT, FMT = 9971 )SUBNAM, INFO, N, N5, IMAT * ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) ) THEN * WRITE( NOUT, FMT = 9978 )SUBNAM, INFO, M, N, IMAT * ELSE IF( LSAMEN( 3, C3, 'CON' ) ) THEN * WRITE( NOUT, FMT = 9969 )SUBNAM, INFO, OPTS( 1: 1 ), M, $ IMAT * ELSE IF( LSAMEN( 3, C3, 'LS ' ) ) THEN * WRITE( NOUT, FMT = 9965 )SUBNAM, INFO, OPTS( 1: 1 ), M, N, $ KL, N5, IMAT * ELSE IF( LSAMEN( 3, C3, 'LSX' ) .OR. LSAMEN( 3, C3, 'LSS' ) ) $ THEN * WRITE( NOUT, FMT = 9974 )SUBNAM, INFO, M, N, KL, N5, IMAT * ELSE * WRITE( NOUT, FMT = 9963 )SUBNAM, INFO, OPTS( 1: 1 ), M, N5, $ IMAT END IF * ELSE IF( LSAMEN( 2, P2, 'GB' ) ) THEN * * xGB: General band matrices * IF( LSAMEN( 3, C3, 'TRF' ) ) THEN IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9989 )SUBNAM, INFO, INFOE, M, N, KL, $ KU, N5, IMAT ELSE WRITE( NOUT, FMT = 9976 )SUBNAM, INFO, M, N, KL, KU, N5, $ IMAT END IF IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9949 ) * ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN * IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9986 )SUBNAM, INFO, INFOE, N, KL, KU, $ N5, IMAT ELSE WRITE( NOUT, FMT = 9972 )SUBNAM, INFO, N, KL, KU, N5, $ IMAT END IF * ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN * IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9993 )SUBNAM, INFO, INFOE, $ OPTS( 1: 1 ), OPTS( 2: 2 ), N, KL, KU, N5, IMAT ELSE WRITE( NOUT, FMT = 9998 )SUBNAM, INFO, OPTS( 1: 1 ), $ OPTS( 2: 2 ), N, KL, KU, N5, IMAT END IF * ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) ) THEN * WRITE( NOUT, FMT = 9977 )SUBNAM, INFO, M, N, KL, KU, IMAT * ELSE IF( LSAMEN( 3, C3, 'CON' ) ) THEN * WRITE( NOUT, FMT = 9968 )SUBNAM, INFO, OPTS( 1: 1 ), M, KL, $ KU, IMAT * ELSE * WRITE( NOUT, FMT = 9964 )SUBNAM, INFO, OPTS( 1: 1 ), M, KL, $ KU, N5, IMAT END IF * ELSE IF( LSAMEN( 2, P2, 'GT' ) ) THEN * * xGT: General tridiagonal matrices * IF( LSAMEN( 3, C3, 'TRF' ) ) THEN IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9987 )SUBNAM, INFO, INFOE, N, IMAT ELSE WRITE( NOUT, FMT = 9973 )SUBNAM, INFO, N, IMAT END IF IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9949 ) * ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN * IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9984 )SUBNAM, INFO, INFOE, N, N5, $ IMAT ELSE WRITE( NOUT, FMT = 9970 )SUBNAM, INFO, N, N5, IMAT END IF * ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN * IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9992 )SUBNAM, INFO, INFOE, $ OPTS( 1: 1 ), OPTS( 2: 2 ), N, N5, IMAT ELSE WRITE( NOUT, FMT = 9997 )SUBNAM, INFO, OPTS( 1: 1 ), $ OPTS( 2: 2 ), N, N5, IMAT END IF * ELSE IF( LSAMEN( 3, C3, 'CON' ) ) THEN * WRITE( NOUT, FMT = 9969 )SUBNAM, INFO, OPTS( 1: 1 ), M, $ IMAT * ELSE * WRITE( NOUT, FMT = 9963 )SUBNAM, INFO, OPTS( 1: 1 ), M, N5, $ IMAT END IF * ELSE IF( LSAMEN( 2, P2, 'PO' ) ) THEN * * xPO: Symmetric or Hermitian positive definite matrices * UPLO = OPTS( 1: 1 ) IF( LSAMEN( 3, C3, 'TRF' ) ) THEN IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9980 )SUBNAM, INFO, INFOE, UPLO, M, $ N5, IMAT ELSE WRITE( NOUT, FMT = 9956 )SUBNAM, INFO, UPLO, M, N5, IMAT END IF IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9949 ) * ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN * IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9979 )SUBNAM, INFO, INFOE, UPLO, N, $ N5, IMAT ELSE WRITE( NOUT, FMT = 9955 )SUBNAM, INFO, UPLO, N, N5, IMAT END IF * ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN * IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9990 )SUBNAM, INFO, INFOE, $ OPTS( 1: 1 ), OPTS( 2: 2 ), N, N5, IMAT ELSE WRITE( NOUT, FMT = 9995 )SUBNAM, INFO, OPTS( 1: 1 ), $ OPTS( 2: 2 ), N, N5, IMAT END IF * ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN * WRITE( NOUT, FMT = 9956 )SUBNAM, INFO, UPLO, M, N5, IMAT * ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) .OR. $ LSAMEN( 3, C3, 'CON' ) ) THEN * WRITE( NOUT, FMT = 9960 )SUBNAM, INFO, UPLO, M, IMAT * ELSE * WRITE( NOUT, FMT = 9955 )SUBNAM, INFO, UPLO, M, N5, IMAT END IF * ELSE IF( LSAMEN( 2, P2, 'SY' ) .OR. LSAMEN( 2, P2, 'HE' ) ) THEN * * xHE, or xSY: Symmetric or Hermitian indefinite matrices * UPLO = OPTS( 1: 1 ) IF( LSAMEN( 3, C3, 'TRF' ) ) THEN IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9980 )SUBNAM, INFO, INFOE, UPLO, M, $ N5, IMAT ELSE WRITE( NOUT, FMT = 9956 )SUBNAM, INFO, UPLO, M, N5, IMAT END IF IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9949 ) * ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN * IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9979 )SUBNAM, INFO, INFOE, UPLO, N, $ N5, IMAT ELSE WRITE( NOUT, FMT = 9955 )SUBNAM, INFO, UPLO, N, N5, IMAT END IF * ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN * IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9990 )SUBNAM, INFO, INFOE, $ OPTS( 1: 1 ), OPTS( 2: 2 ), N, N5, IMAT ELSE WRITE( NOUT, FMT = 9995 )SUBNAM, INFO, OPTS( 1: 1 ), $ OPTS( 2: 2 ), N, N5, IMAT END IF * ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) .OR. $ LSAMEN( 3, C3, 'TRI' ) .OR. LSAMEN( 3, C3, 'CON' ) ) $ THEN * WRITE( NOUT, FMT = 9960 )SUBNAM, INFO, UPLO, M, IMAT * ELSE * WRITE( NOUT, FMT = 9955 )SUBNAM, INFO, UPLO, M, N5, IMAT END IF * ELSE IF( LSAMEN( 2, P2, 'PP' ) .OR. LSAMEN( 2, P2, 'SP' ) .OR. $ LSAMEN( 2, P2, 'HP' ) ) THEN * * xPP, xHP, or xSP: Symmetric or Hermitian packed matrices * UPLO = OPTS( 1: 1 ) IF( LSAMEN( 3, C3, 'TRF' ) ) THEN IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9983 )SUBNAM, INFO, INFOE, UPLO, M, $ IMAT ELSE WRITE( NOUT, FMT = 9960 )SUBNAM, INFO, UPLO, M, IMAT END IF IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9949 ) * ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN * IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9979 )SUBNAM, INFO, INFOE, UPLO, N, $ N5, IMAT ELSE WRITE( NOUT, FMT = 9955 )SUBNAM, INFO, UPLO, N, N5, IMAT END IF * ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN * IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9990 )SUBNAM, INFO, INFOE, $ OPTS( 1: 1 ), OPTS( 2: 2 ), N, N5, IMAT ELSE WRITE( NOUT, FMT = 9995 )SUBNAM, INFO, OPTS( 1: 1 ), $ OPTS( 2: 2 ), N, N5, IMAT END IF * ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) .OR. $ LSAMEN( 3, C3, 'TRI' ) .OR. LSAMEN( 3, C3, 'CON' ) ) $ THEN * WRITE( NOUT, FMT = 9960 )SUBNAM, INFO, UPLO, M, IMAT * ELSE * WRITE( NOUT, FMT = 9955 )SUBNAM, INFO, UPLO, M, N5, IMAT END IF * ELSE IF( LSAMEN( 2, P2, 'PB' ) ) THEN * * xPB: Symmetric (Hermitian) positive definite band matrix * UPLO = OPTS( 1: 1 ) IF( LSAMEN( 3, C3, 'TRF' ) ) THEN IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9982 )SUBNAM, INFO, INFOE, UPLO, M, $ KL, N5, IMAT ELSE WRITE( NOUT, FMT = 9958 )SUBNAM, INFO, UPLO, M, KL, N5, $ IMAT END IF IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9949 ) * ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN * IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9981 )SUBNAM, INFO, INFOE, UPLO, N, $ KL, N5, IMAT ELSE WRITE( NOUT, FMT = 9957 )SUBNAM, INFO, UPLO, N, KL, N5, $ IMAT END IF * ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN * IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9991 )SUBNAM, INFO, INFOE, $ OPTS( 1: 1 ), OPTS( 2: 2 ), N, KL, N5, IMAT ELSE WRITE( NOUT, FMT = 9996 )SUBNAM, INFO, OPTS( 1: 1 ), $ OPTS( 2: 2 ), N, KL, N5, IMAT END IF * ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) .OR. $ LSAMEN( 3, C3, 'CON' ) ) THEN * WRITE( NOUT, FMT = 9959 )SUBNAM, INFO, UPLO, M, KL, IMAT * ELSE * WRITE( NOUT, FMT = 9957 )SUBNAM, INFO, UPLO, M, KL, N5, $ IMAT END IF * ELSE IF( LSAMEN( 2, P2, 'PT' ) ) THEN * * xPT: Positive definite tridiagonal matrices * IF( LSAMEN( 3, C3, 'TRF' ) ) THEN IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9987 )SUBNAM, INFO, INFOE, N, IMAT ELSE WRITE( NOUT, FMT = 9973 )SUBNAM, INFO, N, IMAT END IF IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9949 ) * ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN * IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9984 )SUBNAM, INFO, INFOE, N, N5, $ IMAT ELSE WRITE( NOUT, FMT = 9970 )SUBNAM, INFO, N, N5, IMAT END IF * ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN * IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9994 )SUBNAM, INFO, INFOE, $ OPTS( 1: 1 ), N, N5, IMAT ELSE WRITE( NOUT, FMT = 9999 )SUBNAM, INFO, OPTS( 1: 1 ), N, $ N5, IMAT END IF * ELSE IF( LSAMEN( 3, C3, 'CON' ) ) THEN * IF( LSAME( SUBNAM( 1: 1 ), 'S' ) .OR. $ LSAME( SUBNAM( 1: 1 ), 'D' ) ) THEN WRITE( NOUT, FMT = 9973 )SUBNAM, INFO, M, IMAT ELSE WRITE( NOUT, FMT = 9969 )SUBNAM, INFO, OPTS( 1: 1 ), M, $ IMAT END IF * ELSE * WRITE( NOUT, FMT = 9963 )SUBNAM, INFO, OPTS( 1: 1 ), M, N5, $ IMAT END IF * ELSE IF( LSAMEN( 2, P2, 'TR' ) ) THEN * * xTR: Triangular matrix * IF( LSAMEN( 3, C3, 'TRI' ) ) THEN WRITE( NOUT, FMT = 9961 )SUBNAM, INFO, OPTS( 1: 1 ), $ OPTS( 2: 2 ), M, N5, IMAT ELSE IF( LSAMEN( 3, C3, 'CON' ) ) THEN WRITE( NOUT, FMT = 9967 )SUBNAM, INFO, OPTS( 1: 1 ), $ OPTS( 2: 2 ), OPTS( 3: 3 ), M, IMAT ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATRS' ) ) THEN WRITE( NOUT, FMT = 9952 )SUBNAM, INFO, OPTS( 1: 1 ), $ OPTS( 2: 2 ), OPTS( 3: 3 ), OPTS( 4: 4 ), M, IMAT ELSE WRITE( NOUT, FMT = 9953 )SUBNAM, INFO, OPTS( 1: 1 ), $ OPTS( 2: 2 ), OPTS( 3: 3 ), M, N5, IMAT END IF * ELSE IF( LSAMEN( 2, P2, 'TP' ) ) THEN * * xTP: Triangular packed matrix * IF( LSAMEN( 3, C3, 'TRI' ) ) THEN WRITE( NOUT, FMT = 9962 )SUBNAM, INFO, OPTS( 1: 1 ), $ OPTS( 2: 2 ), M, IMAT ELSE IF( LSAMEN( 3, C3, 'CON' ) ) THEN WRITE( NOUT, FMT = 9967 )SUBNAM, INFO, OPTS( 1: 1 ), $ OPTS( 2: 2 ), OPTS( 3: 3 ), M, IMAT ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATPS' ) ) THEN WRITE( NOUT, FMT = 9952 )SUBNAM, INFO, OPTS( 1: 1 ), $ OPTS( 2: 2 ), OPTS( 3: 3 ), OPTS( 4: 4 ), M, IMAT ELSE WRITE( NOUT, FMT = 9953 )SUBNAM, INFO, OPTS( 1: 1 ), $ OPTS( 2: 2 ), OPTS( 3: 3 ), M, N5, IMAT END IF * ELSE IF( LSAMEN( 2, P2, 'TB' ) ) THEN * * xTB: Triangular band matrix * IF( LSAMEN( 3, C3, 'CON' ) ) THEN WRITE( NOUT, FMT = 9966 )SUBNAM, INFO, OPTS( 1: 1 ), $ OPTS( 2: 2 ), OPTS( 3: 3 ), M, KL, IMAT ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATBS' ) ) THEN WRITE( NOUT, FMT = 9951 )SUBNAM, INFO, OPTS( 1: 1 ), $ OPTS( 2: 2 ), OPTS( 3: 3 ), OPTS( 4: 4 ), M, KL, IMAT ELSE WRITE( NOUT, FMT = 9954 )SUBNAM, INFO, OPTS( 1: 1 ), $ OPTS( 2: 2 ), OPTS( 3: 3 ), M, KL, N5, IMAT END IF * ELSE IF( LSAMEN( 2, P2, 'QR' ) ) THEN * * xQR: QR factorization * IF( LSAMEN( 3, C3, 'QRS' ) ) THEN WRITE( NOUT, FMT = 9974 )SUBNAM, INFO, M, N, KL, N5, IMAT ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) ) THEN WRITE( NOUT, FMT = 9978 )SUBNAM, INFO, M, N, IMAT END IF * ELSE IF( LSAMEN( 2, P2, 'LQ' ) ) THEN * * xLQ: LQ factorization * IF( LSAMEN( 3, C3, 'LQS' ) ) THEN WRITE( NOUT, FMT = 9974 )SUBNAM, INFO, M, N, KL, N5, IMAT ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) ) THEN WRITE( NOUT, FMT = 9978 )SUBNAM, INFO, M, N, IMAT END IF * ELSE IF( LSAMEN( 2, P2, 'QL' ) ) THEN * * xQL: QL factorization * IF( LSAMEN( 3, C3, 'QLS' ) ) THEN WRITE( NOUT, FMT = 9974 )SUBNAM, INFO, M, N, KL, N5, IMAT ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) ) THEN WRITE( NOUT, FMT = 9978 )SUBNAM, INFO, M, N, IMAT END IF * ELSE IF( LSAMEN( 2, P2, 'RQ' ) ) THEN * * xRQ: RQ factorization * IF( LSAMEN( 3, C3, 'RQS' ) ) THEN WRITE( NOUT, FMT = 9974 )SUBNAM, INFO, M, N, KL, N5, IMAT ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) ) THEN WRITE( NOUT, FMT = 9978 )SUBNAM, INFO, M, N, IMAT END IF * ELSE IF( LSAMEN( 2, P2, 'LU' ) ) THEN * IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9988 )SUBNAM, INFO, INFOE, M, N, N5, $ IMAT ELSE WRITE( NOUT, FMT = 9975 )SUBNAM, INFO, M, N, N5, IMAT END IF * ELSE IF( LSAMEN( 2, P2, 'CH' ) ) THEN * IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9985 )SUBNAM, INFO, INFOE, M, N5, IMAT ELSE WRITE( NOUT, FMT = 9971 )SUBNAM, INFO, M, N5, IMAT END IF * ELSE * * Print a generic message if the path is unknown. * WRITE( NOUT, FMT = 9950 )SUBNAM, INFO END IF * * Description of error message (alphabetical, left to right) * * SUBNAM, INFO, FACT, N, NRHS, IMAT * 9999 FORMAT( ' *** Error code from ', A6, '=', I5, ', FACT=''', A1, $ ''', N=', I5, ', NRHS=', I4, ', type ', I2 ) * * SUBNAM, INFO, FACT, TRANS, N, KL, KU, NRHS, IMAT * 9998 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> FACT=''', $ A1, ''', TRANS=''', A1, ''', N=', I5, ', KL=', I5, ', KU=', $ I5, ', NRHS=', I4, ', type ', I1 ) * * SUBNAM, INFO, FACT, TRANS, N, NRHS, IMAT * 9997 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> FACT=''', $ A1, ''', TRANS=''', A1, ''', N =', I5, ', NRHS =', I4, $ ', type ', I2 ) * * SUBNAM, INFO, FACT, UPLO, N, KD, NRHS, IMAT * 9996 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> FACT=''', $ A1, ''', UPLO=''', A1, ''', N=', I5, ', KD=', I5, ', NRHS=', $ I4, ', type ', I2 ) * * SUBNAM, INFO, FACT, UPLO, N, NRHS, IMAT * 9995 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> FACT=''', $ A1, ''', UPLO=''', A1, ''', N =', I5, ', NRHS =', I4, $ ', type ', I2 ) * * SUBNAM, INFO, INFOE, FACT, N, NRHS, IMAT * 9994 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ', $ I2, / ' ==> FACT=''', A1, ''', N =', I5, ', NRHS =', I4, $ ', type ', I2 ) * * SUBNAM, INFO, INFOE, FACT, TRANS, N, KL, KU, NRHS, IMAT * 9993 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ', $ I2, / ' ==> FACT=''', A1, ''', TRANS=''', A1, ''', N=', I5, $ ', KL=', I5, ', KU=', I5, ', NRHS=', I4, ', type ', I1 ) * * SUBNAM, INFO, INFOE, FACT, TRANS, N, NRHS, IMAT * 9992 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ', $ I2, / ' ==> FACT=''', A1, ''', TRANS=''', A1, ''', N =', I5, $ ', NRHS =', I4, ', type ', I2 ) * * SUBNAM, INFO, INFOE, FACT, UPLO, N, KD, NRHS, IMAT * 9991 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ', $ I2, / ' ==> FACT=''', A1, ''', UPLO=''', A1, ''', N=', I5, $ ', KD=', I5, ', NRHS=', I4, ', type ', I2 ) * * SUBNAM, INFO, INFOE, FACT, UPLO, N, NRHS, IMAT * 9990 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ', $ I2, / ' ==> FACT=''', A1, ''', UPLO=''', A1, ''', N =', I5, $ ', NRHS =', I4, ', type ', I2 ) * * SUBNAM, INFO, INFOE, M, N, KL, KU, NB, IMAT * 9989 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ', $ I2, / ' ==> M = ', I5, ', N =', I5, ', KL =', I5, ', KU =', $ I5, ', NB =', I4, ', type ', I2 ) * * SUBNAM, INFO, INFOE, M, N, NB, IMAT * 9988 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ', $ I2, / ' ==> M =', I5, ', N =', I5, ', NB =', I4, ', type ', $ I2 ) * * SUBNAM, INFO, INFOE, N, IMAT * 9987 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ', $ I2, ' for N=', I5, ', type ', I2 ) * * SUBNAM, INFO, INFOE, N, KL, KU, NRHS, IMAT * 9986 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ', $ I2, / ' ==> N =', I5, ', KL =', I5, ', KU =', I5, $ ', NRHS =', I4, ', type ', I2 ) * * SUBNAM, INFO, INFOE, N, NB, IMAT * 9985 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ', $ I2, / ' ==> N =', I5, ', NB =', I4, ', type ', I2 ) * * SUBNAM, INFO, INFOE, N, NRHS, IMAT * 9984 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ', $ I2, / ' ==> N =', I5, ', NRHS =', I4, ', type ', I2 ) * * SUBNAM, INFO, INFOE, UPLO, N, IMAT * 9983 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ', $ I2, / ' ==> UPLO = ''', A1, ''', N =', I5, ', type ', I2 ) * * SUBNAM, INFO, INFOE, UPLO, N, KD, NB, IMAT * 9982 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ', $ I2, / ' ==> UPLO = ''', A1, ''', N =', I5, ', KD =', I5, $ ', NB =', I4, ', type ', I2 ) * * SUBNAM, INFO, INFOE, UPLO, N, KD, NRHS, IMAT * 9981 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ', $ I2, / ' ==> UPLO=''', A1, ''', N =', I5, ', KD =', I5, $ ', NRHS =', I4, ', type ', I2 ) * * SUBNAM, INFO, INFOE, UPLO, N, NB, IMAT * 9980 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ', $ I2, / ' ==> UPLO = ''', A1, ''', N =', I5, ', NB =', I4, $ ', type ', I2 ) * * SUBNAM, INFO, INFOE, UPLO, N, NRHS, IMAT * 9979 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ', $ I2, / ' ==> UPLO = ''', A1, ''', N =', I5, ', NRHS =', I4, $ ', type ', I2 ) * * SUBNAM, INFO, M, N, IMAT * 9978 FORMAT( ' *** Error code from ', A6, ' =', I5, ' for M =', I5, $ ', N =', I5, ', type ', I2 ) * * SUBNAM, INFO, M, N, KL, KU, IMAT * 9977 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> M = ', I5, $ ', N =', I5, ', KL =', I5, ', KU =', I5, ', type ', I2 ) * * SUBNAM, INFO, M, N, KL, KU, NB, IMAT * 9976 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> M = ', I5, $ ', N =', I5, ', KL =', I5, ', KU =', I5, ', NB =', I4, $ ', type ', I2 ) * * SUBNAM, INFO, M, N, NB, IMAT * 9975 FORMAT( ' *** Error code from ', A6, '=', I5, ' for M=', I5, $ ', N=', I5, ', NB=', I4, ', type ', I2 ) * * SUBNAM, INFO, M, N, NRHS, NB, IMAT * 9974 FORMAT( ' *** Error code from ', A6, '=', I5, / ' ==> M =', I5, $ ', N =', I5, ', NRHS =', I4, ', NB =', I4, ', type ', I2 ) * * SUBNAM, INFO, N, IMAT * 9973 FORMAT( ' *** Error code from ', A6, ' =', I5, ' for N =', I5, $ ', type ', I2 ) * * SUBNAM, INFO, N, KL, KU, NRHS, IMAT * 9972 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> N =', I5, $ ', KL =', I5, ', KU =', I5, ', NRHS =', I4, ', type ', I2 ) * * SUBNAM, INFO, N, NB, IMAT * 9971 FORMAT( ' *** Error code from ', A6, '=', I5, ' for N=', I5, $ ', NB=', I4, ', type ', I2 ) * * SUBNAM, INFO, N, NRHS, IMAT * 9970 FORMAT( ' *** Error code from ', A6, ' =', I5, ' for N =', I5, $ ', NRHS =', I4, ', type ', I2 ) * * SUBNAM, INFO, NORM, N, IMAT * 9969 FORMAT( ' *** Error code from ', A6, ' =', I5, ' for NORM = ''', $ A1, ''', N =', I5, ', type ', I2 ) * * SUBNAM, INFO, NORM, N, KL, KU, IMAT * 9968 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> NORM =''', $ A1, ''', N =', I5, ', KL =', I5, ', KU =', I5, ', type ', $ I2 ) * * SUBNAM, INFO, NORM, UPLO, DIAG, N, IMAT * 9967 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> NORM=''', $ A1, ''', UPLO =''', A1, ''', DIAG=''', A1, ''', N =', I5, $ ', type ', I2 ) * * SUBNAM, INFO, NORM, UPLO, DIAG, N, KD, IMAT * 9966 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> NORM=''', $ A1, ''', UPLO =''', A1, ''', DIAG=''', A1, ''', N=', I5, $ ', KD=', I5, ', type ', I2 ) * * SUBNAM, INFO, TRANS, M, N, NRHS, NB, IMAT * 9965 FORMAT( ' *** Error code from ', A6, ' =', I5, $ / ' ==> TRANS = ''', A1, ''', M =', I5, ', N =', I5, $ ', NRHS =', I4, ', NB =', I4, ', type ', I2 ) * * SUBNAM, INFO, TRANS, N, KL, KU, NRHS, IMAT * 9964 FORMAT( ' *** Error code from ', A6, '=', I5, / ' ==> TRANS=''', $ A1, ''', N =', I5, ', KL =', I5, ', KU =', I5, ', NRHS =', $ I4, ', type ', I2 ) * * SUBNAM, INFO, TRANS, N, NRHS, IMAT * 9963 FORMAT( ' *** Error code from ', A6, ' =', I5, $ / ' ==> TRANS = ''', A1, ''', N =', I5, ', NRHS =', I4, $ ', type ', I2 ) * * SUBNAM, INFO, UPLO, DIAG, N, IMAT * 9962 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> UPLO=''', $ A1, ''', DIAG =''', A1, ''', N =', I5, ', type ', I2 ) * * SUBNAM, INFO, UPLO, DIAG, N, NB, IMAT * 9961 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> UPLO=''', $ A1, ''', DIAG =''', A1, ''', N =', I5, ', NB =', I4, $ ', type ', I2 ) * * SUBNAM, INFO, UPLO, N, IMAT * 9960 FORMAT( ' *** Error code from ', A6, ' =', I5, ' for UPLO = ''', $ A1, ''', N =', I5, ', type ', I2 ) * * SUBNAM, INFO, UPLO, N, KD, IMAT * 9959 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> UPLO = ''', $ A1, ''', N =', I5, ', KD =', I5, ', type ', I2 ) * * SUBNAM, INFO, UPLO, N, KD, NB, IMAT * 9958 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> UPLO = ''', $ A1, ''', N =', I5, ', KD =', I5, ', NB =', I4, ', type ', $ I2 ) * * SUBNAM, INFO, UPLO, N, KD, NRHS, IMAT * 9957 FORMAT( ' *** Error code from ', A6, '=', I5, / ' ==> UPLO = ''', $ A1, ''', N =', I5, ', KD =', I5, ', NRHS =', I4, ', type ', $ I2 ) * * SUBNAM, INFO, UPLO, N, NB, IMAT * 9956 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> UPLO = ''', $ A1, ''', N =', I5, ', NB =', I4, ', type ', I2 ) * * SUBNAM, INFO, UPLO, N, NRHS, IMAT * 9955 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> UPLO = ''', $ A1, ''', N =', I5, ', NRHS =', I4, ', type ', I2 ) * * SUBNAM, INFO, UPLO, TRANS, DIAG, N, KD, NRHS, IMAT * 9954 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> UPLO=''', $ A1, ''', TRANS=''', A1, ''', DIAG=''', A1, ''', N=', I5, $ ', KD=', I5, ', NRHS=', I4, ', type ', I2 ) * * SUBNAM, INFO, UPLO, TRANS, DIAG, N, NRHS, IMAT * 9953 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> UPLO=''', $ A1, ''', TRANS=''', A1, ''', DIAG=''', A1, ''', N =', I5, $ ', NRHS =', I4, ', type ', I2 ) * * SUBNAM, INFO, UPLO, TRANS, DIAG, NORMIN, N, IMAT * 9952 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> UPLO=''', $ A1, ''', TRANS=''', A1, ''', DIAG=''', A1, ''', NORMIN=''', $ A1, ''', N =', I5, ', type ', I2 ) * * SUBNAM, INFO, UPLO, TRANS, DIAG, NORMIN, N, KD, IMAT * 9951 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> UPLO=''', $ A1, ''', TRANS=''', A1, ''', DIAG=''', A1, ''', NORMIN=''', $ A1, ''', N=', I5, ', KD=', I5, ', type ', I2 ) * * Unknown type * 9950 FORMAT( ' *** Error code from ', A6, ' =', I5 ) * * What we do next * 9949 FORMAT( ' ==> Doing only the condition estimate for this case' ) * RETURN * * End of ALAERH * END SHAR_EOF fi # end of overwriting check if test -f 'alaesm.f' then echo shar: will not over-write existing file "'alaesm.f'" else cat << SHAR_EOF > 'alaesm.f' SUBROUTINE ALAESM( PATH, OK, NOUT ) * * -- 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 .. LOGICAL OK CHARACTER*3 PATH INTEGER NOUT * .. * * Purpose * ======= * * ALAESM prints a summary of results from one of the -ERR- routines. * * Arguments * ========= * * PATH (input) CHARACTER*3 * The LAPACK path name. * * OK (input) LOGICAL * The flag from CHKXER that indicates whether or not the tests * of error exits passed. * * NOUT (input) INTEGER * The unit number on which results are to be printed. * NOUT >= 0. * * ===================================================================== * * .. Executable Statements .. * IF( OK ) THEN WRITE( NOUT, FMT = 9999 )PATH ELSE WRITE( NOUT, FMT = 9998 )PATH END IF * 9999 FORMAT( 1X, A3, ' routines passed the tests of the error exits' $ ) 9998 FORMAT( ' *** ', A3, ' routines failed the tests of the error ', $ 'exits ***' ) RETURN * * End of ALAESM * END SHAR_EOF fi # end of overwriting check if test -f 'alahd.f' then echo shar: will not over-write existing file "'alahd.f'" else cat << SHAR_EOF > 'alahd.f' SUBROUTINE ALAHD( IOUNIT, PATH ) * * -- 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*3 PATH INTEGER IOUNIT * .. * * Purpose * ======= * * ALAHD prints header information for the different test paths. * * Arguments * ========= * * IOUNIT (input) INTEGER * The unit number to which the header information should be * printed. * * PATH (input) CHARACTER*3 * The name of the path for which the header information is to * be printed. Current paths are * _GE: General matrices * _GB: General band * _GT: General Tridiagonal * _PO: Symmetric or Hermitian positive definite * _PP: Symmetric or Hermitian positive definite packed * _PB: Symmetric or Hermitian positive definite band * _PT: Symmetric or Hermitian positive definite tridiagonal * _SY: Symmetric indefinite * _SP: Symmetric indefinite packed * _HE: (complex) Hermitian indefinite * _HP: (complex) Hermitian indefinite packed * _TR: Triangular * _TP: Triangular packed * _TB: Triangular band * _QR: QR (general matrices) * _LQ: LQ (general matrices) * _QL: QL (general matrices) * _RQ: RQ (general matrices) * _QP: QR with column pivoting * _TZ: Trapezoidal * _LS: Least Squares driver routines * _LU: LU variants * _CH: Cholesky variants * _QS: QR variants * The first character must be one of S, D, C, or Z (C or Z only * if complex). * * ===================================================================== * * .. Local Scalars .. LOGICAL CORZ, SORD CHARACTER C1, C3 CHARACTER*2 P2 CHARACTER*6 SUBNAM CHARACTER*9 SYM * .. * .. External Functions .. LOGICAL LSAME, LSAMEN EXTERNAL LSAME, LSAMEN * .. * .. Executable Statements .. * IF( IOUNIT.LE.0 ) $ RETURN C1 = PATH( 1: 1 ) C3 = PATH( 3: 3 ) P2 = PATH( 2: 3 ) SORD = LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' ) CORZ = LSAME( C1, 'C' ) .OR. LSAME( C1, 'Z' ) IF( .NOT.( SORD .OR. CORZ ) ) $ RETURN * IF( LSAMEN( 2, P2, 'GE' ) ) THEN * * GE: General dense * WRITE( IOUNIT, FMT = 9999 )PATH WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' ) WRITE( IOUNIT, FMT = 9979 ) WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) WRITE( IOUNIT, FMT = 9962 )1 WRITE( IOUNIT, FMT = 9961 )2 WRITE( IOUNIT, FMT = 9960 )3 WRITE( IOUNIT, FMT = 9959 )4 WRITE( IOUNIT, FMT = 9958 )5 WRITE( IOUNIT, FMT = 9957 )6 WRITE( IOUNIT, FMT = 9956 )7 WRITE( IOUNIT, FMT = 9955 )8 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * ELSE IF( LSAMEN( 2, P2, 'GB' ) ) THEN * * GB: General band * WRITE( IOUNIT, FMT = 9998 )PATH WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' ) WRITE( IOUNIT, FMT = 9978 ) WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) WRITE( IOUNIT, FMT = 9962 )1 WRITE( IOUNIT, FMT = 9960 )2 WRITE( IOUNIT, FMT = 9959 )3 WRITE( IOUNIT, FMT = 9958 )4 WRITE( IOUNIT, FMT = 9957 )5 WRITE( IOUNIT, FMT = 9956 )6 WRITE( IOUNIT, FMT = 9955 )7 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * ELSE IF( LSAMEN( 2, P2, 'GT' ) ) THEN * * GT: General tridiagonal * WRITE( IOUNIT, FMT = 9997 )PATH WRITE( IOUNIT, FMT = 9977 ) WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) WRITE( IOUNIT, FMT = 9962 )1 WRITE( IOUNIT, FMT = 9960 )2 WRITE( IOUNIT, FMT = 9959 )3 WRITE( IOUNIT, FMT = 9958 )4 WRITE( IOUNIT, FMT = 9957 )5 WRITE( IOUNIT, FMT = 9956 )6 WRITE( IOUNIT, FMT = 9955 )7 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * ELSE IF( LSAMEN( 2, P2, 'PO' ) .OR. LSAMEN( 2, P2, 'PP' ) ) THEN * * PO: Positive definite full * PP: Positive definite packed * IF( SORD ) THEN SYM = 'Symmetric' ELSE SYM = 'Hermitian' END IF IF( LSAME( C3, 'O' ) ) THEN WRITE( IOUNIT, FMT = 9996 )PATH, SYM ELSE WRITE( IOUNIT, FMT = 9995 )PATH, SYM END IF WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' ) WRITE( IOUNIT, FMT = 9975 )PATH WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) WRITE( IOUNIT, FMT = 9954 )1 WRITE( IOUNIT, FMT = 9961 )2 WRITE( IOUNIT, FMT = 9960 )3 WRITE( IOUNIT, FMT = 9959 )4 WRITE( IOUNIT, FMT = 9958 )5 WRITE( IOUNIT, FMT = 9957 )6 WRITE( IOUNIT, FMT = 9956 )7 WRITE( IOUNIT, FMT = 9955 )8 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * ELSE IF( LSAMEN( 2, P2, 'PB' ) ) THEN * * PB: Positive definite band * IF( SORD ) THEN WRITE( IOUNIT, FMT = 9994 )PATH, 'Symmetric' ELSE WRITE( IOUNIT, FMT = 9994 )PATH, 'Hermitian' END IF WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' ) WRITE( IOUNIT, FMT = 9973 )PATH WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) WRITE( IOUNIT, FMT = 9954 )1 WRITE( IOUNIT, FMT = 9960 )2 WRITE( IOUNIT, FMT = 9959 )3 WRITE( IOUNIT, FMT = 9958 )4 WRITE( IOUNIT, FMT = 9957 )5 WRITE( IOUNIT, FMT = 9956 )6 WRITE( IOUNIT, FMT = 9955 )7 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * ELSE IF( LSAMEN( 2, P2, 'PT' ) ) THEN * * PT: Positive definite tridiagonal * IF( SORD ) THEN WRITE( IOUNIT, FMT = 9993 )PATH, 'Symmetric' ELSE WRITE( IOUNIT, FMT = 9993 )PATH, 'Hermitian' END IF WRITE( IOUNIT, FMT = 9976 ) WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) WRITE( IOUNIT, FMT = 9952 )1 WRITE( IOUNIT, FMT = 9960 )2 WRITE( IOUNIT, FMT = 9959 )3 WRITE( IOUNIT, FMT = 9958 )4 WRITE( IOUNIT, FMT = 9957 )5 WRITE( IOUNIT, FMT = 9956 )6 WRITE( IOUNIT, FMT = 9955 )7 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * ELSE IF( LSAMEN( 2, P2, 'SY' ) .OR. LSAMEN( 2, P2, 'SP' ) ) THEN * * SY: Symmetric indefinite full * SP: Symmetric indefinite packed * IF( LSAME( C3, 'Y' ) ) THEN WRITE( IOUNIT, FMT = 9992 )PATH, 'Symmetric' ELSE WRITE( IOUNIT, FMT = 9991 )PATH, 'Symmetric' END IF WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' ) IF( SORD ) THEN WRITE( IOUNIT, FMT = 9972 ) ELSE WRITE( IOUNIT, FMT = 9971 ) END IF WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) WRITE( IOUNIT, FMT = 9953 )1 WRITE( IOUNIT, FMT = 9961 )2 WRITE( IOUNIT, FMT = 9960 )3 WRITE( IOUNIT, FMT = 9959 )4 WRITE( IOUNIT, FMT = 9958 )5 WRITE( IOUNIT, FMT = 9956 )6 WRITE( IOUNIT, FMT = 9957 )7 WRITE( IOUNIT, FMT = 9955 )8 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * ELSE IF( LSAMEN( 2, P2, 'HE' ) .OR. LSAMEN( 2, P2, 'HP' ) ) THEN * * HE: Hermitian indefinite full * HP: Hermitian indefinite packed * IF( LSAME( C3, 'E' ) ) THEN WRITE( IOUNIT, FMT = 9992 )PATH, 'Hermitian' ELSE WRITE( IOUNIT, FMT = 9991 )PATH, 'Hermitian' END IF WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' ) WRITE( IOUNIT, FMT = 9972 ) WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) WRITE( IOUNIT, FMT = 9953 )1 WRITE( IOUNIT, FMT = 9961 )2 WRITE( IOUNIT, FMT = 9960 )3 WRITE( IOUNIT, FMT = 9959 )4 WRITE( IOUNIT, FMT = 9958 )5 WRITE( IOUNIT, FMT = 9956 )6 WRITE( IOUNIT, FMT = 9957 )7 WRITE( IOUNIT, FMT = 9955 )8 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * ELSE IF( LSAMEN( 2, P2, 'TR' ) .OR. LSAMEN( 2, P2, 'TP' ) ) THEN * * TR: Triangular full * TP: Triangular packed * IF( LSAME( C3, 'R' ) ) THEN WRITE( IOUNIT, FMT = 9990 )PATH SUBNAM = PATH( 1: 1 ) // 'LATRS' ELSE WRITE( IOUNIT, FMT = 9989 )PATH SUBNAM = PATH( 1: 1 ) // 'LATPS' END IF WRITE( IOUNIT, FMT = 9966 )PATH WRITE( IOUNIT, FMT = 9965 )SUBNAM WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) WRITE( IOUNIT, FMT = 9961 )1 WRITE( IOUNIT, FMT = 9960 )2 WRITE( IOUNIT, FMT = 9959 )3 WRITE( IOUNIT, FMT = 9958 )4 WRITE( IOUNIT, FMT = 9957 )5 WRITE( IOUNIT, FMT = 9956 )6 WRITE( IOUNIT, FMT = 9955 )7 WRITE( IOUNIT, FMT = 9951 )SUBNAM, 8 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * ELSE IF( LSAMEN( 2, P2, 'TB' ) ) THEN * * TB: Triangular band * WRITE( IOUNIT, FMT = 9988 )PATH SUBNAM = PATH( 1: 1 ) // 'LATBS' WRITE( IOUNIT, FMT = 9964 )PATH WRITE( IOUNIT, FMT = 9963 )SUBNAM WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) WRITE( IOUNIT, FMT = 9960 )1 WRITE( IOUNIT, FMT = 9959 )2 WRITE( IOUNIT, FMT = 9958 )3 WRITE( IOUNIT, FMT = 9957 )4 WRITE( IOUNIT, FMT = 9956 )5 WRITE( IOUNIT, FMT = 9955 )6 WRITE( IOUNIT, FMT = 9951 )SUBNAM, 7 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * ELSE IF( LSAMEN( 2, P2, 'QR' ) ) THEN * * QR decomposition of rectangular matrices * WRITE( IOUNIT, FMT = 9987 )PATH, 'QR' WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' ) WRITE( IOUNIT, FMT = 9970 ) WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) WRITE( IOUNIT, FMT = 9950 )1 WRITE( IOUNIT, FMT = 9946 )2 WRITE( IOUNIT, FMT = 9944 )3, 'M' WRITE( IOUNIT, FMT = 9943 )4, 'M' WRITE( IOUNIT, FMT = 9942 )5, 'M' WRITE( IOUNIT, FMT = 9941 )6, 'M' WRITE( IOUNIT, FMT = 9960 )7 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * ELSE IF( LSAMEN( 2, P2, 'LQ' ) ) THEN * * LQ decomposition of rectangular matrices * WRITE( IOUNIT, FMT = 9987 )PATH, 'LQ' WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' ) WRITE( IOUNIT, FMT = 9970 ) WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) WRITE( IOUNIT, FMT = 9949 )1 WRITE( IOUNIT, FMT = 9945 )2 WRITE( IOUNIT, FMT = 9944 )3, 'N' WRITE( IOUNIT, FMT = 9943 )4, 'N' WRITE( IOUNIT, FMT = 9942 )5, 'N' WRITE( IOUNIT, FMT = 9941 )6, 'N' WRITE( IOUNIT, FMT = 9960 )7 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * ELSE IF( LSAMEN( 2, P2, 'QL' ) ) THEN * * QL decomposition of rectangular matrices * WRITE( IOUNIT, FMT = 9987 )PATH, 'QL' WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' ) WRITE( IOUNIT, FMT = 9970 ) WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) WRITE( IOUNIT, FMT = 9948 )1 WRITE( IOUNIT, FMT = 9946 )2 WRITE( IOUNIT, FMT = 9944 )3, 'M' WRITE( IOUNIT, FMT = 9943 )4, 'M' WRITE( IOUNIT, FMT = 9942 )5, 'M' WRITE( IOUNIT, FMT = 9941 )6, 'M' WRITE( IOUNIT, FMT = 9960 )7 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * ELSE IF( LSAMEN( 2, P2, 'RQ' ) ) THEN * * RQ decomposition of rectangular matrices * WRITE( IOUNIT, FMT = 9987 )PATH, 'RQ' WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' ) WRITE( IOUNIT, FMT = 9970 ) WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) WRITE( IOUNIT, FMT = 9947 )1 WRITE( IOUNIT, FMT = 9945 )2 WRITE( IOUNIT, FMT = 9944 )3, 'N' WRITE( IOUNIT, FMT = 9943 )4, 'N' WRITE( IOUNIT, FMT = 9942 )5, 'N' WRITE( IOUNIT, FMT = 9941 )6, 'N' WRITE( IOUNIT, FMT = 9960 )7 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * ELSE IF( LSAMEN( 2, P2, 'QP' ) ) THEN * * QR decomposition with column pivoting * WRITE( IOUNIT, FMT = 9986 )PATH WRITE( IOUNIT, FMT = 9969 ) WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) WRITE( IOUNIT, FMT = 9940 )1 WRITE( IOUNIT, FMT = 9939 )2 WRITE( IOUNIT, FMT = 9938 )3 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * ELSE IF( LSAMEN( 2, P2, 'RR' ) ) THEN * * Rank-Revealing QR decomposition * WRITE( IOUNIT, FMT = 9920 )PATH WRITE( IOUNIT, FMT = 9929 ) WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) WRITE( IOUNIT, FMT = 9928 )1 WRITE( IOUNIT, FMT = 9927 )2 WRITE( IOUNIT, FMT = 9926 )3 WRITE( IOUNIT, FMT = 9925 )4 WRITE( IOUNIT, FMT = 9924 )5 WRITE( IOUNIT, FMT = 9923 )6 WRITE( IOUNIT, FMT = 9922 )7 WRITE( IOUNIT, FMT = 9921 ) WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * ELSE IF( LSAMEN( 2, P2, 'TZ' ) ) THEN * * TZ: Trapezoidal * WRITE( IOUNIT, FMT = 9985 )PATH WRITE( IOUNIT, FMT = 9968 ) WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) WRITE( IOUNIT, FMT = 9940 )1 WRITE( IOUNIT, FMT = 9937 )2 WRITE( IOUNIT, FMT = 9938 )3 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * ELSE IF( LSAMEN( 2, P2, 'LS' ) ) THEN * * LS: Least Squares driver routines * WRITE( IOUNIT, FMT = 9984 )PATH WRITE( IOUNIT, FMT = 9967 ) WRITE( IOUNIT, FMT = 9936 )C1, C1, C1 WRITE( IOUNIT, FMT = 9935 )1 WRITE( IOUNIT, FMT = 9931 )2 WRITE( IOUNIT, FMT = 9933 )3 WRITE( IOUNIT, FMT = 9935 )4 WRITE( IOUNIT, FMT = 9934 )5 WRITE( IOUNIT, FMT = 9932 )6 WRITE( IOUNIT, FMT = 9930 ) WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * ELSE IF( LSAMEN( 2, P2, 'LU' ) ) THEN * * LU factorization variants * WRITE( IOUNIT, FMT = 9983 )PATH WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' ) WRITE( IOUNIT, FMT = 9979 ) WRITE( IOUNIT, FMT = '( '' Test ratio:'' )' ) WRITE( IOUNIT, FMT = 9962 )1 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * ELSE IF( LSAMEN( 2, P2, 'CH' ) ) THEN * * Cholesky factorization variants * WRITE( IOUNIT, FMT = 9982 )PATH WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' ) WRITE( IOUNIT, FMT = 9974 ) WRITE( IOUNIT, FMT = '( '' Test ratio:'' )' ) WRITE( IOUNIT, FMT = 9954 )1 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * ELSE IF( LSAMEN( 2, P2, 'QS' ) ) THEN * * QR factorization variants * WRITE( IOUNIT, FMT = 9981 )PATH WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' ) WRITE( IOUNIT, FMT = 9970 ) WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) * ELSE * * Print error message if no header is available. * WRITE( IOUNIT, FMT = 9980 )PATH END IF * * First line of header * 9999 FORMAT( / 1X, A3, ': General dense matrices' ) 9998 FORMAT( / 1X, A3, ': General band matrices' ) 9997 FORMAT( / 1X, A3, ': General tridiagonal' ) 9996 FORMAT( / 1X, A3, ': ', A9, ' positive definite matrices' ) 9995 FORMAT( / 1X, A3, ': ', A9, ' positive definite packed matrices' $ ) 9994 FORMAT( / 1X, A3, ': ', A9, ' positive definite band matrices' ) 9993 FORMAT( / 1X, A3, ': ', A9, ' positive definite tridiagonal' ) 9992 FORMAT( / 1X, A3, ': ', A9, ' indefinite matrices' ) 9991 FORMAT( / 1X, A3, ': ', A9, ' indefinite packed matrices' ) 9990 FORMAT( / 1X, A3, ': Triangular matrices' ) 9989 FORMAT( / 1X, A3, ': Triangular packed matrices' ) 9988 FORMAT( / 1X, A3, ': Triangular band matrices' ) 9987 FORMAT( / 1X, A3, ': ', A2, ' factorization of general matrices' $ ) 9986 FORMAT( / 1X, A3, ': QR factorization with column pivoting' ) 9920 FORMAT( / 1X, A3, ': Rank-Revealing QR factorization' ) 9985 FORMAT( / 1X, A3, ': RQ factorization of trapezoidal matrix' ) 9984 FORMAT( / 1X, A3, ': Least squares driver routines' ) 9983 FORMAT( / 1X, A3, ': LU factorization variants' ) 9982 FORMAT( / 1X, A3, ': Cholesky factorization variants' ) 9981 FORMAT( / 1X, A3, ': QR factorization variants' ) 9980 FORMAT( / 1X, A3, ': No header available' ) * * GE matrix types * 9979 FORMAT( 4X, '1. Diagonal', 24X, '7. Last n/2 columns zero', / 4X, $ '2. Upper triangular', 16X, $ '8. Random, CNDNUM = sqrt(0.1/EPS)', / 4X, $ '3. Lower triangular', 16X, '9. Random, CNDNUM = 0.1/EPS', $ / 4X, '4. Random, CNDNUM = 2', 13X, $ '10. Scaled near underflow', / 4X, '5. First column zero', $ 14X, '11. Scaled near overflow', / 4X, $ '6. Last column zero' ) * * GB matrix types * 9978 FORMAT( 4X, '1. Random, CNDNUM = 2', 14X, $ '5. Random, CNDNUM = sqrt(0.1/EPS)', / 4X, $ '2. First column zero', 15X, '6. Random, CNDNUM = .01/EPS', $ / 4X, '3. Last column zero', 16X, $ '7. Scaled near underflow', / 4X, $ '4. Last n/2 columns zero', 11X, '8. Scaled near overflow' ) * * GT matrix types * 9977 FORMAT( ' Matrix types (1-6 have specified condition numbers):', $ / 4X, '1. Diagonal', 24X, '7. Random, unspecified CNDNUM', $ / 4X, '2. Random, CNDNUM = 2', 14X, '8. First column zero', $ / 4X, '3. Random, CNDNUM = sqrt(0.1/EPS)', 2X, $ '9. Last column zero', / 4X, '4. Random, CNDNUM = 0.1/EPS', $ 7X, '10. Last n/2 columns zero', / 4X, $ '5. Scaled near underflow', 10X, $ '11. Scaled near underflow', / 4X, $ '6. Scaled near overflow', 11X, '12. Scaled near overflow' ) * * PT matrix types * 9976 FORMAT( ' Matrix types (1-6 have specified condition numbers):', $ / 4X, '1. Diagonal', 24X, '7. Random, unspecified CNDNUM', $ / 4X, '2. Random, CNDNUM = 2', 14X, $ '8. First row and column zero', / 4X, $ '3. Random, CNDNUM = sqrt(0.1/EPS)', 2X, $ '9. Last row and column zero', / 4X, $ '4. Random, CNDNUM = 0.1/EPS', 7X, $ '10. Middle row and column zero', / 4X, $ '5. Scaled near underflow', 10X, $ '11. Scaled near underflow', / 4X, $ '6. Scaled near overflow', 11X, '12. Scaled near overflow' ) * * PO, PP matrix types * 9975 FORMAT( 4X, '1. Diagonal', 24X, $ '6. Random, CNDNUM = sqrt(0.1/EPS)', / 4X, $ '2. Random, CNDNUM = 2', 14X, '7. Random, CNDNUM = 0.1/EPS', $ / 3X, '*3. First row and column zero', 7X, $ '8. Scaled near underflow', / 3X, $ '*4. Last row and column zero', 8X, $ '9. Scaled near overflow', / 3X, $ '*5. Middle row and column zero', / 3X, $ '(* - tests error exits from ', A3, $ 'TRF, no test ratios are computed)' ) * * CH matrix types * 9974 FORMAT( 4X, '1. Diagonal', 24X, $ '6. Random, CNDNUM = sqrt(0.1/EPS)', / 4X, $ '2. Random, CNDNUM = 2', 14X, '7. Random, CNDNUM = 0.1/EPS', $ / 3X, '*3. First row and column zero', 7X, $ '8. Scaled near underflow', / 3X, $ '*4. Last row and column zero', 8X, $ '9. Scaled near overflow', / 3X, $ '*5. Middle row and column zero', / 3X, $ '(* - tests error exits, no test ratios are computed)' ) * * PB matrix types * 9973 FORMAT( 4X, '1. Random, CNDNUM = 2', 14X, $ '5. Random, CNDNUM = sqrt(0.1/EPS)', / 3X, $ '*2. First row and column zero', 7X, $ '6. Random, CNDNUM = 0.1/EPS', / 3X, $ '*3. Last row and column zero', 8X, $ '7. Scaled near underflow', / 3X, $ '*4. Middle row and column zero', 6X, $ '8. Scaled near overflow', / 3X, $ '(* - tests error exits from ', A3, $ 'TRF, no test ratios are computed)' ) * * SSY, SSP, CHE, CHP matrix types * 9972 FORMAT( 4X, '1. Diagonal', 24X, $ '6. Last n/2 rows and columns zero', / 4X, $ '2. Random, CNDNUM = 2', 14X, $ '7. Random, CNDNUM = sqrt(0.1/EPS)', / 4X, $ '3. First row and column zero', 7X, $ '8. Random, CNDNUM = 0.1/EPS', / 4X, $ '4. Last row and column zero', 8X, $ '9. Scaled near underflow', / 4X, $ '5. Middle row and column zero', 5X, $ '10. Scaled near overflow' ) * * CSY, CSP matrix types * 9971 FORMAT( 4X, '1. Diagonal', 24X, $ '7. Random, CNDNUM = sqrt(0.1/EPS)', / 4X, $ '2. Random, CNDNUM = 2', 14X, '8. Random, CNDNUM = 0.1/EPS', $ / 4X, '3. First row and column zero', 7X, $ '9. Scaled near underflow', / 4X, $ '4. Last row and column zero', 7X, $ '10. Scaled near overflow', / 4X, $ '5. Middle row and column zero', 5X, $ '11. Block diagonal matrix', / 4X, $ '6. Last n/2 rows and columns zero' ) * * QR matrix types * 9970 FORMAT( 4X, '1. Diagonal', 24X, $ '5. Random, CNDNUM = sqrt(0.1/EPS)', / 4X, $ '2. Upper triangular', 16X, '6. Random, CNDNUM = 0.1/EPS', $ / 4X, '3. Lower triangular', 16X, $ '7. Scaled near underflow', / 4X, '4. Random, CNDNUM = 2', $ 14X, '8. Scaled near overflow' ) * * QP matrix types * 9969 FORMAT( ' Matrix types (2-6 have condition 1/EPS):', / 4X, $ '1. Zero matrix', 21X, '4. First n/2 columns fixed', / 4X, $ '2. One small eigenvalue', 12X, '5. Last n/2 columns fixed', $ / 4X, '3. Geometric distribution', 10X, $ '6. Every second column fixed' ) * * RR matrix types * 9929 FORMAT( ' Matrix types (2-3 have condition 1/EPS):', / 4X, $ '1. Zero matrix', / 4X, $ '2. One small eigenvalue', / 4X, $ '3. Geometric distribution' ) * * TZ matrix types * 9968 FORMAT( ' Matrix types (2-3 have condition 1/EPS):', / 4X, $ '1. Zero matrix', / 4X, '2. One small eigenvalue', / 4X, $ '3. Geometric distribution' ) * * LS matrix types * 9967 FORMAT( ' Matrix types (1-3: full rank, 4-6: rank deficient):', $ / 4X, '1 and 4. Normal scaling', / 4X, $ '2 and 5. Scaled near overflow', / 4X, $ '3 and 6. Scaled near underflow' ) * * TR, TP matrix types * 9966 FORMAT( ' Matrix types for ', A3, ' routines:', / 4X, $ '1. Diagonal', 24X, '6. Scaled near overflow', / 4X, $ '2. Random, CNDNUM = 2', 14X, '7. Identity', / 4X, $ '3. Random, CNDNUM = sqrt(0.1/EPS) ', $ '8. Unit triangular, CNDNUM = 2', / 4X, $ '4. Random, CNDNUM = 0.1/EPS', 8X, $ '9. Unit, CNDNUM = sqrt(0.1/EPS)', / 4X, $ '5. Scaled near underflow', 10X, $ '10. Unit, CNDNUM = 0.1/EPS' ) 9965 FORMAT( ' Special types for testing ', A6, ':', / 3X, $ '11. Matrix elements are O(1), large right hand side', / 3X, $ '12. First diagonal causes overflow,', $ ' offdiagonal column norms < 1', / 3X, $ '13. First diagonal causes overflow,', $ ' offdiagonal column norms > 1', / 3X, $ '14. Growth factor underflows, solution does not overflow', $ / 3X, '15. Small diagonal causes gradual overflow', / 3X, $ '16. One zero diagonal element', / 3X, $ '17. Large offdiagonals cause overflow when adding a column' $ , / 3X, '18. Unit triangular with large right hand side' ) * * TB matrix types * 9964 FORMAT( ' Matrix types for ', A3, ' routines:', / 4X, $ '1. Random, CNDNUM = 2', 14X, '6. Identity', / 4X, $ '2. Random, CNDNUM = sqrt(0.1/EPS) ', $ '7. Unit triangular, CNDNUM = 2', / 4X, $ '3. Random, CNDNUM = 0.1/EPS', 8X, $ '8. Unit, CNDNUM = sqrt(0.1/EPS)', / 4X, $ '4. Scaled near underflow', 11X, $ '9. Unit, CNDNUM = 0.1/EPS', / 4X, $ '5. Scaled near overflow' ) 9963 FORMAT( ' Special types for testing ', A6, ':', / 3X, $ '10. Matrix elements are O(1), large right hand side', / 3X, $ '11. First diagonal causes overflow,', $ ' offdiagonal column norms < 1', / 3X, $ '12. First diagonal causes overflow,', $ ' offdiagonal column norms > 1', / 3X, $ '13. Growth factor underflows, solution does not overflow', $ / 3X, '14. Small diagonal causes gradual overflow', / 3X, $ '15. One zero diagonal element', / 3X, $ '16. Large offdiagonals cause overflow when adding a column' $ , / 3X, '17. Unit triangular with large right hand side' ) * * Test ratios * 9962 FORMAT( 3X, I2, ': norm( L * U - A ) / ( N * norm(A) * EPS )' ) 9961 FORMAT( 3X, I2, ': norm( I - A*AINV ) / ', $ '( N * norm(A) * norm(AINV) * EPS )' ) 9960 FORMAT( 3X, I2, ': norm( B - A * X ) / ', $ '( norm(A) * norm(X) * EPS )' ) 9959 FORMAT( 3X, I2, ': norm( X - XACT ) / ', $ '( norm(XACT) * CNDNUM * EPS )' ) 9958 FORMAT( 3X, I2, ': norm( X - XACT ) / ', $ '( norm(XACT) * CNDNUM * EPS ), refined' ) 9957 FORMAT( 3X, I2, ': norm( X - XACT ) / ', $ '( norm(XACT) * (error bound) )' ) 9956 FORMAT( 3X, I2, ': (backward error) / EPS' ) 9955 FORMAT( 3X, I2, ': RCOND * CNDNUM - 1.0' ) 9954 FORMAT( 3X, I2, ': norm( U'' * U - A ) / ( N * norm(A) * EPS )', $ ', or', / 7X, 'norm( L * L'' - A ) / ( N * norm(A) * EPS )' $ ) 9953 FORMAT( 3X, I2, ': norm( U*D*U'' - A ) / ( N * norm(A) * EPS )', $ ', or', / 7X, 'norm( L*D*L'' - A ) / ( N * norm(A) * EPS )' $ ) 9952 FORMAT( 3X, I2, ': norm( U''*D*U - A ) / ( N * norm(A) * EPS )', $ ', or', / 7X, 'norm( L*D*L'' - A ) / ( N * norm(A) * EPS )' $ ) 9951 FORMAT( ' Test ratio for ', A6, ':', / 3X, I2, $ ': norm( s*b - A*x ) / ( norm(A) * norm(x) * EPS )' ) 9950 FORMAT( 3X, I2, ': norm( R - Q'' * A ) / ( M * norm(A) * EPS )' ) 9949 FORMAT( 3X, I2, ': norm( L - A * Q'' ) / ( N * norm(A) * EPS )' ) 9948 FORMAT( 3X, I2, ': norm( L - Q'' * A ) / ( M * norm(A) * EPS )' ) 9947 FORMAT( 3X, I2, ': norm( R - A * Q'' ) / ( N * norm(A) * EPS )' ) 9946 FORMAT( 3X, I2, ': norm( I - Q''*Q ) / ( M * EPS )' ) 9945 FORMAT( 3X, I2, ': norm( I - Q*Q'' ) / ( N * EPS )' ) 9944 FORMAT( 3X, I2, ': norm( Q*C - Q*C ) / ', '( ', A1, $ ' * norm(C) * EPS )' ) 9943 FORMAT( 3X, I2, ': norm( C*Q - C*Q ) / ', '( ', A1, $ ' * norm(C) * EPS )' ) 9942 FORMAT( 3X, I2, ': norm( Q''*C - Q''*C )/ ', '( ', A1, $ ' * norm(C) * EPS )' ) 9941 FORMAT( 3X, I2, ': norm( C*Q'' - C*Q'' )/ ', '( ', A1, $ ' * norm(C) * EPS )' ) 9940 FORMAT( 3X, I2, ': norm(svd(A) - svd(R)) / ', $ '( M * norm(svd(R)) * EPS )' ) 9939 FORMAT( 3X, I2, ': norm( A*P - Q*R ) / ( M * norm(A) * EPS )' $ ) 9938 FORMAT( 3X, I2, ': norm( I - Q''*Q ) / ( M * EPS )' ) 9937 FORMAT( 3X, I2, ': norm( A - R*Q ) / ( M * norm(A) * EPS )' $ ) 9936 FORMAT( ' Test ratios (1-2: ', A1, 'GELS, 3-6: ', A1, $ 'GELSS, 7-10: ', A1, 'GELSX):' ) 9935 FORMAT( 3X, I2, ': norm( B - A * X ) / ', $ '( max(M,N) * norm(A) * norm(X) * EPS )' ) 9934 FORMAT( 3X, I2, ': norm( (A*X-B)'' *A ) / ', $ '( max(M,N,NRHS) * norm(A) * norm(B) * EPS )' ) 9933 FORMAT( 3X, I2, ': norm(svd(A)-svd(R)) / ', $ '( min(M,N) * norm(svd(R)) * EPS )' ) 9932 FORMAT( 3X, I2, ': Check if X is in the row space of A or A''' ) 9931 FORMAT( 3X, I2, ': norm( (A*X-B)'' *A ) / ', $ '( max(M,N,NRHS) * norm(A) * norm(B) * EPS )', / 7X, $ 'if TRANS=''N'' and M.GE.N or TRANS=''T'' and M.LT.N, ', $ 'otherwise', / 7X, $ 'check if X is in the row space of A or A'' ', $ '(overdetermined case)' ) 9930 FORMAT( 3X, ' 7-10: same as 3-6' ) * 9928 FORMAT( 3X, I2, ': xGEQPX w/ JOB=1 norm(svd(A) - svd(R)) / ', $ '( M * norm(svd(R)) * EPS )' ) 9927 FORMAT( 3X, I2, ': xGEQPX w/ JOB=2 norm(svd(A) - svd(R)) / ', $ '( M * norm(svd(R)) * EPS )' ) 9926 FORMAT( 3X, I2, ': xGEQPX w/ JOB=2 ', $ 'norm( A*P - Q*R ) / ( M * norm(A) * EPS )' ) 9925 FORMAT( 3X, I2, ': xGEQPX w/ JOB=2 ', $ 'norm( I - Q''*Q ) / ( M * EPS )' ) 9924 FORMAT( 3X, I2, ': xGEQPX w/ JOB=3 norm(svd(A) - svd(R)) / ', $ '( M * norm(svd(R)) * EPS )' ) 9923 FORMAT( 3X, I2, ': xGEQPX w/ JOB=3 ', $ 'norm( A*P - Q*R ) / ( M * norm(A) * EPS )' ) 9922 FORMAT( 3X, I2, ': xGEQPX w/ JOB=3 ', $ 'norm( I - Q''*Q ) / ( M * EPS )' ) 9921 FORMAT( 3X, ' 8-14: same as 1-7 for xGEQPY' ) * RETURN * * End of ALAHD * END SHAR_EOF fi # end of overwriting check if test -f 'alareq.f' then echo shar: will not over-write existing file "'alareq.f'" else cat << SHAR_EOF > 'alareq.f' SUBROUTINE ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) * * -- 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*3 PATH INTEGER NIN, NMATS, NOUT, NTYPES * .. * .. Array Arguments .. LOGICAL DOTYPE( * ) * .. * * Purpose * ======= * * ALAREQ handles input for the LAPACK test program. It is called * to evaluate the input line which requested NMATS matrix types for * PATH. The flow of control is as follows: * * If NMATS = NTYPES then * DOTYPE(1:NTYPES) = .TRUE. * else * Read the next input line for NMATS matrix types * Set DOTYPE(I) = .TRUE. for each valid type I * endif * * Arguments * ========= * * PATH (input) CHARACTER*3 * An LAPACK path name for testing. * * NMATS (input) INTEGER * The number of matrix types to be used in testing this path. * * DOTYPE (output) LOGICAL array, dimension (NTYPES) * The vector of flags indicating if each type will be tested. * * NTYPES (input) INTEGER * The maximum number of matrix types for this path. * * NIN (input) INTEGER * The unit number for input. NIN >= 1. * * NOUT (input) INTEGER * The unit number for output. NOUT >= 1. * * ===================================================================== * * .. Local Scalars .. LOGICAL FIRSTT CHARACTER C1 CHARACTER*10 INTSTR CHARACTER*80 LINE INTEGER I, I1, IC, J, K, LENP, NT * .. * .. Local Arrays .. INTEGER NREQ( 100 ) * .. * .. Intrinsic Functions .. INTRINSIC LEN * .. * .. Data statements .. DATA INTSTR / '0123456789' / * .. * .. Executable Statements .. * IF( NMATS.GE.NTYPES ) THEN * * Test everything if NMATS >= NTYPES. * DO 10 I = 1, NTYPES DOTYPE( I ) = .TRUE. 10 CONTINUE ELSE DO 20 I = 1, NTYPES DOTYPE( I ) = .FALSE. 20 CONTINUE FIRSTT = .TRUE. * * Read a line of matrix types if 0 < NMATS < NTYPES. * IF( NMATS.GT.0 ) THEN READ( NIN, FMT = '(A80)', END = 90 )LINE LENP = LEN( LINE ) I = 0 DO 60 J = 1, NMATS NREQ( J ) = 0 I1 = 0 30 CONTINUE I = I + 1 IF( I.GT.LENP ) THEN IF( J.EQ.NMATS .AND. I1.GT.0 ) THEN GO TO 60 ELSE WRITE( NOUT, FMT = 9995 )LINE WRITE( NOUT, FMT = 9994 )NMATS GO TO 80 END IF END IF IF( LINE( I: I ).NE.' ' .AND. LINE( I: I ).NE.',' ) THEN I1 = I C1 = LINE( I1: I1 ) * * Check that a valid integer was read * DO 40 K = 1, 10 IF( C1.EQ.INTSTR( K: K ) ) THEN IC = K - 1 GO TO 50 END IF 40 CONTINUE WRITE( NOUT, FMT = 9996 )I, LINE WRITE( NOUT, FMT = 9994 )NMATS GO TO 80 50 CONTINUE NREQ( J ) = 10*NREQ( J ) + IC GO TO 30 ELSE IF( I1.GT.0 ) THEN GO TO 60 ELSE GO TO 30 END IF 60 CONTINUE END IF DO 70 I = 1, NMATS NT = NREQ( I ) IF( NT.GT.0 .AND. NT.LE.NTYPES ) THEN IF( DOTYPE( NT ) ) THEN IF( FIRSTT ) $ WRITE( NOUT, FMT = * ) FIRSTT = .FALSE. WRITE( NOUT, FMT = 9997 )NT, PATH END IF DOTYPE( NT ) = .TRUE. ELSE WRITE( NOUT, FMT = 9999 )PATH, NT, NTYPES 9999 FORMAT( ' *** Invalid type request for ', A3, ', type ', $ I4, ': must satisfy 1 <= type <= ', I2 ) END IF 70 CONTINUE 80 CONTINUE END IF RETURN * 90 CONTINUE WRITE( NOUT, FMT = 9998 )PATH 9998 FORMAT( /' *** End of file reached when trying to read matrix ', $ 'types for ', A3, /' *** Check that you are requesting the', $ ' right number of types for each path', / ) 9997 FORMAT( ' *** Warning: duplicate request of matrix type ', I2, $ ' for ', A3 ) 9996 FORMAT( //' *** Invalid integer value in column ', I2, $ ' of input', ' line:', /A79 ) 9995 FORMAT( //' *** Not enough matrix types on input line', /A79 ) 9994 FORMAT( ' ==> Specify ', I4, ' matrix types on this line or ', $ 'adjust NTYPES on previous line' ) WRITE( NOUT, FMT = * ) STOP * * End of ALAREQ * END SHAR_EOF fi # end of overwriting check if test -f 'alasum.f' then echo shar: will not over-write existing file "'alasum.f'" else cat << SHAR_EOF > 'alasum.f' SUBROUTINE ALASUM( TYPE, NOUT, NFAIL, NRUN, NERRS ) * * -- 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*3 TYPE INTEGER NFAIL, NOUT, NRUN, NERRS * .. * * Purpose * ======= * * ALASUM prints a summary of results from one of the -CHK- routines. * * Arguments * ========= * * TYPE (input) CHARACTER*3 * The LAPACK path name. * * NOUT (input) INTEGER * The unit number on which results are to be printed. * NOUT >= 0. * * NFAIL (input) INTEGER * The number of tests which did not pass the threshold ratio. * * NRUN (input) INTEGER * The total number of tests. * * NERRS (input) INTEGER * The number of error messages recorded. * * ===================================================================== * * .. Executable Statements .. * IF( NFAIL.GT.0 ) THEN WRITE( NOUT, FMT = 9999 )TYPE, NFAIL, NRUN ELSE WRITE( NOUT, FMT = 9998 )TYPE, NRUN END IF IF( NERRS.GT.0 ) THEN WRITE( NOUT, FMT = 9997 )NERRS END IF * 9999 FORMAT( 1X, A3, ': ', I6, ' out of ', I6, $ ' tests failed to pass the threshold' ) 9998 FORMAT( /1X, 'All tests for ', A3, $ ' routines passed the threshold (', I6, ' tests run)' ) 9997 FORMAT( 6X, I6, ' error messages recorded' ) RETURN * * End of ALASUM * END SHAR_EOF fi # end of overwriting check if test -f 'alasvm.f' then echo shar: will not over-write existing file "'alasvm.f'" else cat << SHAR_EOF > 'alasvm.f' SUBROUTINE ALASVM( TYPE, NOUT, NFAIL, NRUN, NERRS ) * * -- 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*3 TYPE INTEGER NFAIL, NOUT, NRUN, NERRS * .. * * Purpose * ======= * * ALASVM prints a summary of results from one of the -DRV- routines. * * Arguments * ========= * * TYPE (input) CHARACTER*3 * The LAPACK path name. * * NOUT (input) INTEGER * The unit number on which results are to be printed. * NOUT >= 0. * * NFAIL (input) INTEGER * The number of tests which did not pass the threshold ratio. * * NRUN (input) INTEGER * The total number of tests. * * NERRS (input) INTEGER * The number of error messages recorded. * * ===================================================================== * * .. Executable Statements .. * IF( NFAIL.GT.0 ) THEN WRITE( NOUT, FMT = 9999 )TYPE, NFAIL, NRUN ELSE WRITE( NOUT, FMT = 9998 )TYPE, NRUN END IF IF( NERRS.GT.0 ) THEN WRITE( NOUT, FMT = 9997 )NERRS END IF * 9999 FORMAT( 1X, A3, ' drivers: ', I6, ' out of ', I6, $ ' tests failed to pass the threshold' ) 9998 FORMAT( /1X, 'All tests for ', A3, ' drivers passed the ', $ 'threshold (', I6, ' tests run)' ) 9997 FORMAT( 14X, I6, ' error messages recorded' ) RETURN * * End of ALASVM * END SHAR_EOF fi # end of overwriting check if test -f 'cchkaa.f' then echo shar: will not over-write existing file "'cchkaa.f'" else cat << SHAR_EOF > 'cchkaa.f' PROGRAM CCHKAA * * -- 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 * * Purpose * ======= * * CCHKAA is the main test program for the COMPLEX linear * equation routines. * * An annotated example of a data file can be obtained by deleting the * first 3 characters from the following lines: * Data file for testing COMPLEX LAPACK linear equation routines * 7 Number of values of M * 0 1 2 3 5 10 16 Values of M (row dimension) * 7 Number of values of N * 0 1 2 3 5 10 16 Values of N (column dimension) * 5 Number of values of NB * 1 3 3 3 20 Values of NB (the blocksize) * 1 0 5 9 1 Values of NX (crossover point) * 30.0 Threshold value of test ratio * T Put T to test the LAPACK routines * T Put T to test the driver routines * T Put T to test the error exits * CQP 6 List types on next line if 0 < NTYPES < 6 * CRR 3 List types on next line if 0 < NTYPES < 3 * * Internal Parameters * =================== * * NMAX INTEGER * The maximum allowable value for N. * * MAXIN INTEGER * The number of different values that can be used for each of * M, N, or NB * * MAXRHS INTEGER * The maximum number of right hand sides * * NIN INTEGER * The unit number for input * * NOUT INTEGER * The unit number for output * * LWORK INTEGER * The workspace length * * ===================================================================== * * .. Parameters .. INTEGER NMAX PARAMETER ( NMAX = 501 ) INTEGER MAXIN PARAMETER ( MAXIN = 12 ) INTEGER MAXRHS PARAMETER ( MAXRHS = 10 ) INTEGER MATMAX PARAMETER ( MATMAX = 30 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER KDMAX PARAMETER ( KDMAX = NMAX+( NMAX+1 ) / 4 ) * INTEGER LWORK PARAMETER ( LWORK = NMAX*( NMAX+MAXRHS ) ) * .. * .. Local Scalars .. LOGICAL FATAL, TSTCHK, TSTERR CHARACTER C1 CHARACTER*2 C2 CHARACTER*3 PATH CHARACTER*10 INTSTR CHARACTER*72 ALINE INTEGER I, IC, J, K, LDA, NB, NM, NMATS, NN, $ NNB, NNB2, NTYPES REAL EPS, S1, S2, THREQ, THRESH * .. * .. Local Arrays .. LOGICAL DOTYPE( MATMAX ) INTEGER IWORK( 3*NMAX ), MVAL( MAXIN ), NBVAL( MAXIN ), $ NBVAL2( MAXIN ), NVAL( MAXIN ), NXVAL( MAXIN ) REAL RWORK( 5*NMAX+2*MAXRHS ), S( 2*NMAX ) COMPLEX A( ( KDMAX+1 )*NMAX, 7 ), B( NMAX*MAXRHS, 4 ), $ WORK( NMAX, NMAX+MAXRHS ) * .. * .. External Functions .. LOGICAL LSAME, LSAMEN REAL SLAMCH, SECOND EXTERNAL LSAME, LSAMEN, SLAMCH, SECOND * .. * .. External Subroutines .. EXTERNAL ALAREQ, CCHKQP, CCHKRR * .. * .. Scalars in Common .. LOGICAL LERR, OK CHARACTER*6 SRNAMT INTEGER INFOT, NUNIT * .. * .. Arrays in Common .. INTEGER IPARMS( 100 ) * .. * .. Common blocks .. COMMON / INFOC / INFOT, NUNIT, OK, LERR COMMON / SRNAMC / SRNAMT COMMON / CLAENV / IPARMS * .. * .. Data statements .. DATA THREQ / 2.0D0 / , INTSTR / '0123456789' / * .. * .. Executable Statements .. * S1 = SECOND( ) LDA = NMAX FATAL = .FALSE. * * Read a dummy line. * READ( NIN, FMT = * ) * * Report values of parameters. * WRITE( NOUT, FMT = 9993 ) * * Read the values of M * READ( NIN, FMT = * )NM IF( NM.LT.1 ) THEN WRITE( NOUT, FMT = 9996 )' NM ', NM, 1 NM = 0 FATAL = .TRUE. ELSE IF( NM.GT.MAXIN ) THEN WRITE( NOUT, FMT = 9995 )' NM ', NM, MAXIN NM = 0 FATAL = .TRUE. END IF READ( NIN, FMT = * )( MVAL( I ), I = 1, NM ) DO 10 I = 1, NM IF( MVAL( I ).LT.0 ) THEN WRITE( NOUT, FMT = 9996 )' M ', MVAL( I ), 0 FATAL = .TRUE. ELSE IF( MVAL( I ).GT.NMAX ) THEN WRITE( NOUT, FMT = 9995 )' M ', MVAL( I ), NMAX FATAL = .TRUE. END IF 10 CONTINUE IF( NM.GT.0 ) $ WRITE( NOUT, FMT = 9992 )'M ', ( MVAL( I ), I = 1, NM ) * * Read the values of N * READ( NIN, FMT = * )NN IF( NN.LT.1 ) THEN WRITE( NOUT, FMT = 9996 )' NN ', NN, 1 NN = 0 FATAL = .TRUE. ELSE IF( NN.GT.MAXIN ) THEN WRITE( NOUT, FMT = 9995 )' NN ', NN, MAXIN NN = 0 FATAL = .TRUE. END IF READ( NIN, FMT = * )( NVAL( I ), I = 1, NN ) DO 20 I = 1, NN IF( NVAL( I ).LT.0 ) THEN WRITE( NOUT, FMT = 9996 )' N ', NVAL( I ), 0 FATAL = .TRUE. ELSE IF( NVAL( I ).GT.NMAX ) THEN WRITE( NOUT, FMT = 9995 )' N ', NVAL( I ), NMAX FATAL = .TRUE. END IF 20 CONTINUE IF( NN.GT.0 ) $ WRITE( NOUT, FMT = 9992 )'N ', ( NVAL( I ), I = 1, NN ) * * Read the values of NB * READ( NIN, FMT = * )NNB IF( NNB.LT.1 ) THEN WRITE( NOUT, FMT = 9996 )'NNB ', NNB, 1 NNB = 0 FATAL = .TRUE. ELSE IF( NNB.GT.MAXIN ) THEN WRITE( NOUT, FMT = 9995 )'NNB ', NNB, MAXIN NNB = 0 FATAL = .TRUE. END IF READ( NIN, FMT = * )( NBVAL( I ), I = 1, NNB ) DO 40 I = 1, NNB IF( NBVAL( I ).LT.0 ) THEN WRITE( NOUT, FMT = 9996 )' NB ', NBVAL( I ), 0 FATAL = .TRUE. END IF 40 CONTINUE IF( NNB.GT.0 ) $ WRITE( NOUT, FMT = 9992 )'NB ', ( NBVAL( I ), I = 1, NNB ) * * Set NBVAL2 to be the set of unique values of NB * NNB2 = 0 DO 60 I = 1, NNB NB = NBVAL( I ) DO 50 J = 1, NNB2 IF( NB.EQ.NBVAL2( J ) ) $ GO TO 60 50 CONTINUE NNB2 = NNB2 + 1 NBVAL2( NNB2 ) = NB 60 CONTINUE * * Read the values of NX * READ( NIN, FMT = * )( NXVAL( I ), I = 1, NNB ) DO 70 I = 1, NNB IF( NXVAL( I ).LT.0 ) THEN WRITE( NOUT, FMT = 9996 )' NX ', NXVAL( I ), 0 FATAL = .TRUE. END IF 70 CONTINUE IF( NNB.GT.0 ) $ WRITE( NOUT, FMT = 9992 )'NX ', ( NXVAL( I ), I = 1, NNB ) * * Read the threshold value for the test ratios. * READ( NIN, FMT = * )THRESH WRITE( NOUT, FMT = 9991 )THRESH * * Read the flag that indicates whether to test the LAPACK routines. * READ( NIN, FMT = * )TSTCHK * * Read the flag that indicates whether to test the error exits. * READ( NIN, FMT = * )TSTERR * IF( FATAL ) THEN WRITE( NOUT, FMT = 9999 ) STOP END IF * * Calculate and print the machine dependent constants. * EPS = SLAMCH( 'Underflow threshold' ) WRITE( NOUT, FMT = 9990 )'underflow', EPS EPS = SLAMCH( 'Overflow threshold' ) WRITE( NOUT, FMT = 9990 )'overflow ', EPS EPS = SLAMCH( 'Epsilon' ) WRITE( NOUT, FMT = 9990 )'precision', EPS WRITE( NOUT, FMT = * ) * 80 CONTINUE * * Read a test path and the number of matrix types to use. * READ( NIN, FMT = '(A72)', END = 140 )ALINE PATH = ALINE( 1: 3 ) NMATS = MATMAX I = 3 90 CONTINUE I = I + 1 IF( I.GT.72 ) $ GO TO 130 IF( ALINE( I: I ).EQ.' ' ) $ GO TO 90 NMATS = 0 100 CONTINUE C1 = ALINE( I: I ) DO 110 K = 1, 10 IF( C1.EQ.INTSTR( K: K ) ) THEN IC = K - 1 GO TO 120 END IF 110 CONTINUE GO TO 130 120 CONTINUE NMATS = NMATS*10 + IC I = I + 1 IF( I.GT.72 ) $ GO TO 130 GO TO 100 130 CONTINUE C1 = PATH( 1: 1 ) C2 = PATH( 2: 3 ) * * Check first character for correct precision. * IF( .NOT.LSAME( C1, 'C precision' ) ) THEN WRITE( NOUT, FMT = 9989 )PATH * ELSE IF( NMATS.LE.0 ) THEN * * Check for a positive number of tests requested. * WRITE( NOUT, FMT = 9988 )PATH * ELSE IF( LSAMEN( 2, C2, 'QP' ) ) THEN * * QP: QR factorization with pivoting * NTYPES = 6 CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) * IF( TSTCHK ) THEN CALL CCHKQP( DOTYPE, NM, MVAL, NN, NVAL, THRESH, $ TSTERR, A( 1, 1 ), A( 1, 2 ), S( 1 ), $ S( NMAX+1 ), B( 1, 1 ), WORK, RWORK, IWORK, $ NOUT ) ELSE WRITE( NOUT, FMT = 9988 )PATH END IF * ELSE IF( LSAMEN( 2, C2, 'RR' ) ) THEN * * RR: Rank-Revealing QR factorization * NTYPES = 3 CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) * IF( TSTCHK ) THEN CALL CCHKRR( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, $ NXVAL, THRESH, TSTERR, A( 1, 1 ), A( 1, 2 ), $ A( 1, 3 ), S( 1 ), S( NMAX+1 ), $ WORK, LWORK, RWORK, IWORK, NOUT ) ELSE WRITE( NOUT, FMT = 9988 )PATH END IF * ELSE * WRITE( NOUT, FMT = 9989 )PATH END IF * * Go back to get another input line. * GO TO 80 * * Branch to this line when the last record is read. * 140 CONTINUE CLOSE ( NIN ) S2 = SECOND( ) WRITE( NOUT, FMT = 9998 ) WRITE( NOUT, FMT = 9997 )S2 - S1 * 9999 FORMAT( / ' Execution not attempted due to input errors' ) 9998 FORMAT( / ' End of tests' ) 9997 FORMAT( ' Total time used = ', F12.2, ' seconds', / ) 9996 FORMAT( ' Invalid input value: ', A4, '=', I6, '; must be >=', $ I6 ) 9995 FORMAT( ' Invalid input value: ', A4, '=', I6, '; must be <=', $ I6 ) 9993 FORMAT( ' RRQR Tests. COMPLEX LAPACK routines ', $ / / ' The following parameter values will be used:' ) 9992 FORMAT( 4X, A4, ': ', 10I6, / 11X, 10I6 ) 9991 FORMAT( / ' Routines pass computational tests if test ratio is ', $ 'less than', F8.2, / ) 9990 FORMAT( ' Relative machine ', A, ' is taken to be', D16.6 ) 9989 FORMAT( / 1X, A3, ': Unrecognized path name' ) 9988 FORMAT( / 1X, A3, ' routines were not tested' ) * * End of CCHKAA * END SHAR_EOF fi # end of overwriting check if test -f 'cchkqp.f' then echo shar: will not over-write existing file "'cchkqp.f'" else cat << SHAR_EOF > 'cchkqp.f' SUBROUTINE CCHKQP( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A, $ COPYA, S, COPYS, TAU, WORK, RWORK, IWORK, $ NOUT ) * * -- 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 .. LOGICAL TSTERR INTEGER NM, NN, NOUT REAL THRESH * .. * .. Array Arguments .. LOGICAL DOTYPE( * ) INTEGER IWORK( * ), MVAL( * ), NVAL( * ) REAL COPYS( * ), RWORK( * ), S( * ) COMPLEX A( * ), COPYA( * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * CCHKQP tests CGEQPF. * * Arguments * ========= * * DOTYPE (input) LOGICAL array, dimension (NTYPES) * The matrix types to be used for testing. Matrices of type j * (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = * .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. * * NM (input) INTEGER * The number of values of M contained in the vector MVAL. * * MVAL (input) INTEGER array, dimension (NM) * The values of the matrix row dimension M. * * NN (input) INTEGER * The number of values of N contained in the vector NVAL. * * NVAL (input) INTEGER array, dimension (NN) * The values of the matrix column dimension N. * * THRESH (input) REAL * The threshold value for the test ratios. A result is * included in the output file if RESULT >= THRESH. To have * every test ratio printed, use THRESH = 0. * * TSTERR (input) LOGICAL * Flag that indicates whether error exits are to be tested. * * A (workspace) COMPLEX array, dimension (MMAX*NMAX) * where MMAX is the maximum value of M in MVAL and NMAX is the * maximum value of N in NVAL. * * COPYA (workspace) COMPLEX array, dimension (MMAX*NMAX) * * S (workspace) REAL array, dimension * (min(MMAX,NMAX)) * * COPYS (workspace) REAL array, dimension * (min(MMAX,NMAX)) * * TAU (workspace) COMPLEX array, dimension (MMAX) * * WORK (workspace) COMPLEX array, dimension * (max(M*max(M,N) + 4*min(M,N) + max(M,N))) * * RWORK (workspace) REAL array, dimension (4*NMAX) * * IWORK (workspace) INTEGER array, dimension (NMAX) * * NOUT (input) INTEGER * The unit number for output. * * ===================================================================== * * .. Parameters .. INTEGER NTYPES PARAMETER ( NTYPES = 6 ) INTEGER NTESTS PARAMETER ( NTESTS = 3 ) REAL ONE, ZERO PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 ) * .. * .. Local Scalars .. CHARACTER*3 PATH INTEGER I, IHIGH, ILOW, IM, IMODE, IN, INFO, ISTEP, K, $ LDA, LWORK, M, MNMIN, MODE, N, NERRS, NFAIL, $ NRUN REAL EPS * .. * .. Local Arrays .. INTEGER ISEED( 4 ), ISEEDY( 4 ) REAL RESULT( NTESTS ) * .. * .. External Functions .. REAL CQPT01, CQRT11, CQRT12, SLAMCH EXTERNAL CQPT01, CQRT11, CQRT12, SLAMCH * .. * .. External Subroutines .. EXTERNAL ALAHD, ALASUM, CERRQP, CGEQPF, CLACPY, CLASET, $ CLATMS, SLAORD * .. * .. Intrinsic Functions .. INTRINSIC CMPLX, MAX, MIN * .. * .. Scalars in Common .. LOGICAL LERR, OK CHARACTER*6 SRNAMT INTEGER INFOT, IOUNIT * .. * .. Common blocks .. COMMON / INFOC / INFOT, IOUNIT, OK, LERR COMMON / SRNAMC / SRNAMT * .. * .. Data statements .. DATA ISEEDY / 1988, 1989, 1990, 1991 / * .. * .. Executable Statements .. * * Initialize constants and the random number seed. * PATH( 1: 1 ) = 'C' PATH( 2: 3 ) = 'QP' NRUN = 0 NFAIL = 0 NERRS = 0 DO 10 I = 1, 4 ISEED( I ) = ISEEDY( I ) 10 CONTINUE EPS = SLAMCH( 'Epsilon' ) * * Test the error exits * IF( TSTERR ) $ CALL CERRQP( PATH, NOUT ) INFOT = 0 * DO 80 IM = 1, NM * * Do for each value of M in MVAL. * M = MVAL( IM ) LDA = MAX( 1, M ) * DO 70 IN = 1, NN * * Do for each value of N in NVAL. * N = NVAL( IN ) MNMIN = MIN( M, N ) LWORK = MAX( 1, M*MAX( M, N )+4*MNMIN+MAX( M, N ) ) * DO 60 IMODE = 1, NTYPES IF( .NOT.DOTYPE( IMODE ) ) $ GO TO 60 * * Do for each type of matrix * 1: zero matrix * 2: one small singular value * 3: geometric distribution of singular values * 4: first n/2 columns fixed * 5: last n/2 columns fixed * 6: every second column fixed * MODE = IMODE IF( IMODE.GT.3 ) $ MODE = 1 * * Generate test matrix of size m by n using * singular value distribution indicated by 'mode'. * DO 20 I = 1, N IWORK( I ) = 0 20 CONTINUE IF( IMODE.EQ.1 ) THEN CALL CLASET( 'Full', M, N, CMPLX( ZERO ), $ CMPLX( ZERO ), COPYA, LDA ) DO 30 I = 1, MNMIN COPYS( I ) = ZERO 30 CONTINUE ELSE CALL CLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', COPYS, $ MODE, ONE / EPS, ONE, M, N, 'No packing', $ COPYA, LDA, WORK, INFO ) IF( IMODE.GE.4 ) THEN IF( IMODE.EQ.4 ) THEN ILOW = 1 ISTEP = 1 IHIGH = MAX( 1, N / 2 ) ELSE IF( IMODE.EQ.5 ) THEN ILOW = MAX( 1, N / 2 ) ISTEP = 1 IHIGH = N ELSE IF( IMODE.EQ.6 ) THEN ILOW = 1 ISTEP = 2 IHIGH = N END IF DO 40 I = ILOW, IHIGH, ISTEP IWORK( I ) = 1 40 CONTINUE END IF CALL SLAORD( 'Decreasing', MNMIN, COPYS, 1 ) END IF * * Save A and its singular values * CALL CLACPY( 'All', M, N, COPYA, LDA, A, LDA ) * * Compute the QR factorization with pivoting of A * SRNAMT = 'CGEQPF' CALL CGEQPF( M, N, A, LDA, IWORK, TAU, WORK, RWORK, $ INFO ) * * Compute norm(svd(a) - svd(r)) * RESULT( 1 ) = CQRT12( M, N, A, LDA, COPYS, WORK, LWORK, $ RWORK ) * * Compute norm( A*P - Q*R ) * RESULT( 2 ) = CQPT01( M, N, MNMIN, COPYA, A, LDA, TAU, $ IWORK, WORK, LWORK ) * * Compute Q'*Q * RESULT( 3 ) = CQRT11( M, MNMIN, A, LDA, TAU, WORK, $ LWORK ) * * Print information about the tests that did not pass * the threshold. * DO 50 K = 1, 3 IF( RESULT( K ).GE.THRESH ) THEN IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) $ CALL ALAHD( NOUT, PATH ) WRITE( NOUT, FMT = 9999 )M, N, IMODE, K, $ RESULT( K ) NFAIL = NFAIL + 1 END IF 50 CONTINUE NRUN = NRUN + 3 60 CONTINUE 70 CONTINUE 80 CONTINUE * * Print a summary of the results. * CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) * 9999 FORMAT( ' M =', I5, ', N =', I5, ', type ', I2, ', test ', I2, $ ', ratio =', G12.5 ) * * End of CCHKQP * END SHAR_EOF fi # end of overwriting check if test -f 'cchkrr.f' then echo shar: will not over-write existing file "'cchkrr.f'" else cat << SHAR_EOF > 'cchkrr.f' SUBROUTINE CCHKRR( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, $ NXVAL, THRESH, TSTERR, A, AQ, COPYA, S, COPYS, $ WORK, LNWK, RWORK, IWORK, NOUT ) * * -- 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 * * Rewritten to test RRQR Subroutines. * * .. Scalar Arguments .. LOGICAL TSTERR INTEGER LNWK, NM, NN, NNB, NOUT REAL THRESH * .. * .. Array Arguments .. LOGICAL DOTYPE( * ) INTEGER IWORK( * ), MVAL( * ), NVAL( * ), $ NBVAL( * ), NXVAL( * ) REAL COPYS( * ), RWORK( * ), S( * ) COMPLEX A( * ), AQ( * ), COPYA( * ), WORK( * ) * .. * * Purpose * ======= * * CCHKRR tests CGEQPX and CGEQPY. * * Arguments * ========= * * DOTYPE (input) LOGICAL array, dimension (NTYPES) * The matrix types to be used for testing. Matrices of type j * (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = * .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. * * NM (input) INTEGER * The number of values of M contained in the vector MVAL. * * MVAL (input) INTEGER array, dimension (NM) * The values of the matrix row dimension M. * * NN (input) INTEGER * The number of values of N contained in the vector NVAL. * * NVAL (input) INTEGER array, dimension (NN) * The values of the matrix column dimension N. * * NNB (input) INTEGER * The number of values of NB and NX contained in the * vectors NBVAL and NXVAL. The blocking parameters are used * in pairs (NB,NX). * * NBVAL (input) INTEGER array, dimension (NNB) * The values of the blocksize NB. * * NXVAL (input) INTEGER array, dimension (NNB) * The values of the crossover point NX. * * THRESH (input) REAL * The threshold value for the test ratios. A result is * included in the output file if RESULT >= THRESH. To have * every test ratio printed, use THRESH = 0. * * TSTERR (input) LOGICAL * Flag that indicates whether error exits are to be tested. * * A (workspace) COMPLEX array, dimension (MMAX*NMAX) * where MMAX is the maximum value of M in MVAL and NMAX is the * maximum value of N in NVAL. * * AQ (workspace) COMPLEX array, dimension (MMAX*NMAX) * where MMAX is the maximum value of M in MVAL and NMAX is the * maximum value of N in NVAL. * * COPYA (workspace) COMPLEX array, dimension (MMAX*NMAX) * * S (workspace) REAL array, dimension * (min(MMAX,NMAX)) * * COPYS (workspace) REAL array, dimension * (min(MMAX,NMAX)) * * WORK (workspace) COMPLEX array, dimension (LNWK) * * LNWK (input) INTEGER * Workspace length. At least * ((max(M*max(M,N) + 4*min(M,N) + max(M,N))). * * RWORK (workspace) REAL array, dimension (4*NMAX) * * IWORK (workspace) INTEGER array, dimension (NMAX) * * NOUT (input) INTEGER * The unit number for output. * * ===================================================================== * * .. Parameters .. INTEGER NTYPES PARAMETER ( NTYPES = 3 ) INTEGER NTESTS PARAMETER ( NTESTS = 14 ) REAL ONE, ZERO COMPLEX CONE, CZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0, $ CONE = ( 1.0E+0, 0.0E+0 ), $ CZERO = ( 0.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. CHARACTER*3 PATH INTEGER I, IM, IMODE, IN, INB, INFO, K, $ LDA, LW, LWORK, M, MNMIN, N, NB, NERRS, NFAIL, $ NRUN, NX, RANK REAL EPS, IRCOND, ORCOND * .. * .. Local Arrays .. INTEGER ISEED( 4 ), ISEEDY( 4 ) REAL RESULT( NTESTS ), SVLUES( 4 ) * .. * .. External Functions .. REAL SLAMCH, CQRT12, CRRT01, $ CRRT02 EXTERNAL SLAMCH, CQRT12, CRRT01, $ CRRT02 * .. * .. External Subroutines .. EXTERNAL ALAHD, ALASUM, SLAORD, CERRRR, $ CGEQPX, CGEQPY, $ CLACPY, CLASET, CLATMS * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Scalars in Common .. LOGICAL LERR, OK CHARACTER*6 SRNAMT INTEGER INFOT, IOUNIT * .. * .. Common blocks .. COMMON / INFOC / INFOT, IOUNIT, OK, LERR COMMON / SRNAMC / SRNAMT * .. * .. Data statements .. DATA ISEEDY / 1988, 1989, 1990, 1991 / * .. * .. Executable Statements .. * * Initialize constants and the random number seed. * PATH( 1: 1 ) = 'C' PATH( 2: 3 ) = 'RR' NRUN = 0 NFAIL = 0 NERRS = 0 DO 10 I = 1, 4 ISEED( I ) = ISEEDY( I ) 10 CONTINUE EPS = SLAMCH( 'Epsilon' ) IRCOND = EPS * * Test the error exits * IF( TSTERR ) $ CALL CERRRR( PATH, NOUT ) INFOT = 0 * DO 80 IM = 1, NM * * Do for each value of M in MVAL. * M = MVAL( IM ) LDA = MAX( 1, M ) * DO 70 IN = 1, NN * * Do for each value of N in NVAL. * N = NVAL( IN ) MNMIN = MIN( M, N ) LWORK = MAX( 1, M*MAX( M, N )+4*MNMIN+MAX( M, N ) ) * * Check if there is enough workspace. * IF( LWORK.GT.LNWK ) THEN WRITE(*,*) ' Error in CCHKRR.', 'Code 1:', $ ' Actual Workspace:', LNWK, $ ' Needed Workspace :', LWORK STOP ENDIF * DO 60 IMODE = 1, NTYPES IF( .NOT.DOTYPE( IMODE ) ) $ GO TO 60 * * Do for each type of matrix * 1: zero matrix * 2: one small singular value * 3: geometric distribution of singular values * * Generate test matrix of size m by n using * singular value distribution indicated by 'mode'. * IF( IMODE.EQ.1 ) THEN CALL CLASET( 'Full', M, N, CZERO, CZERO, COPYA, $ LDA ) DO 30 I = 1, MNMIN COPYS( I ) = ZERO 30 CONTINUE ELSE CALL CLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', $ COPYS, IMODE, ONE / EPS, ONE, M, N, $ 'No packing', COPYA, LDA, WORK, INFO ) CALL SLAORD( 'Decreasing', MNMIN, COPYS, 1 ) END IF * DO 90 INB = 1, NNB * * Do for each pair of values (NB,NX) in NBVAL and NXVAL. * NB = NBVAL( INB ) CALL XLAENV( 1, NB ) NX = NXVAL( INB ) CALL XLAENV( 3, NX ) * * ****************** * * Testing yGEQPX * * ****************** * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Test yGEQPX when JOB=1 * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Get a work copy of matrix A from COPYA. * CALL CLACPY( 'All', M, N, COPYA, LDA, A, LDA ) * * Compute the Rank-Revealing QR factorization of A * IF ( NB.LT.3 ) THEN LW = MAX( 1, 2*MNMIN+N ) ELSE LW = MAX( 1, 2*MNMIN+N*NB ) END IF * * Check if there is enough workspace for current * block size. * IF( LW.GT.LNWK ) THEN WRITE(*,*) ' Error in PREC_CHKRR.', 'Code 2', $ ' Workspace too short for blocksize',nb WRITE(*,*) ' Actual Workspace:', LNWK, $ ' Needed Workspace :', LW STOP ENDIF * SRNAMT = 'CGEQPX' CALL CGEQPX( 1, M, N, 0, A, LDA, AQ, LDA, IWORK, $ IRCOND, ORCOND, RANK, SVLUES, WORK, LW, $ RWORK, INFO ) * * Compute norm(svd(a) - svd(r)) * RESULT( 1 ) = CQRT12( M, N, A, LDA, COPYS, WORK, $ LWORK, RWORK ) * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Test yGEQPX when JOB=2 * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Get a work copy of matrix A from COPYA. * CALL CLACPY( 'All', M, N, COPYA, LDA, A, LDA ) * * Set WORK to identity. * CALL CLASET( 'All', M, M, CZERO, CONE, AQ, LDA ) * * Compute the Rank-Revealing QR factorization of A * IF ( NB.LT.3 ) THEN LW = MAX( 1, 2*MNMIN+MAX(N,M) ) ELSE LW = MAX( 1, 2*MNMIN+NB*NB+NB*MAX(N,M) ) END IF SRNAMT = 'CGEQPX' CALL CGEQPX( 2, M, N, M, A, LDA, AQ, LDA, IWORK, $ IRCOND, ORCOND, RANK, SVLUES, WORK, LW, $ RWORK, INFO ) * * Compute norm(svd(a) - svd(r)) * RESULT( 2 ) = CQRT12( M, N, A, LDA, COPYS, WORK, $ LWORK, RWORK ) * * Compute norm( A*P - Q*R ) * RESULT( 3 ) = CRRT01( 'Conjugate Transpose', $ M, N, COPYA, LDA, IWORK, $ AQ, LDA, A, LDA, WORK, LWORK ) * * Compute norm( Q'*Q - Identity ) * RESULT( 4 ) = CRRT02( M, AQ, LDA, WORK, LWORK ) * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Test yGEQPX when JOB=3 * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Get a work copy of matrix A from COPYA. * CALL CLACPY( 'All', M, N, COPYA, LDA, A, LDA ) * * Set WORK to identity. * CALL CLASET( 'All', M, M, CZERO, CONE, AQ, LDA ) * * Compute the Rank-Revealing QR factorization of A * IF ( NB.LT.3 ) THEN LW = MAX( 1, 2*MNMIN+MAX(N,M) ) ELSE LW = MAX( 1, 2*MNMIN+NB*NB+NB*MAX(N,M) ) END IF SRNAMT = 'CGEQPX' CALL CGEQPX( 3, M, N, M, A, LDA, AQ, LDA, IWORK, $ IRCOND, ORCOND, RANK, SVLUES, WORK, LW, $ RWORK, INFO ) * * Compute norm(svd(a) - svd(r)) * RESULT( 5 ) = CQRT12( M, N, A, LDA, COPYS, WORK, $ LWORK, RWORK ) * * Compute norm( A*P - Q*R ) * RESULT( 6 ) = CRRT01( 'No transpose', M, N, $ COPYA, LDA, IWORK, $ AQ, LDA, A, LDA, WORK, LWORK ) * * Compute norm( Q'*Q - Identity ) * RESULT( 7 ) = CRRT02( M, AQ, LDA, WORK, LWORK ) * * * *-*-*-*-*-*-*-*-*-*-* * * Printing results * * *-*-*-*-*-*-*-*-*-*-* * * Print information about the tests that did not pass * the threshold. * DO 100 K = 1, 7 IF( RESULT( K ).GE.THRESH ) THEN IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) $ CALL ALAHD( NOUT, PATH ) WRITE( NOUT, FMT = 9999 ) 'CGEQPX', M, N, $ NB, IMODE, K, $ RESULT( K ) NFAIL = NFAIL + 1 END IF 100 CONTINUE NRUN = NRUN + 7 * * * ****************** * * Testing yGEQPY * * ****************** * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Test yGEQPY when JOB=1 * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Get a work copy of matrix A from COPYA. * CALL CLACPY( 'All', M, N, COPYA, LDA, A, LDA ) * * Compute the Rank-Revealing QR factorization of A * IF ( NB.LT.3 ) THEN LW = MAX( 1, 2*MNMIN+N ) ELSE LW = MAX( 1, 2*MNMIN+N*NB ) END IF * * Check if there is enough workspace for current * block size. * IF( LW.GT.LNWK ) THEN WRITE(*,*) ' Error in PREC_CHKRR.', 'Code 2', $ ' Workspace too short for blocksize',nb WRITE(*,*) ' Actual Workspace:', LNWK, $ ' Needed Workspace :', LW STOP ENDIF * SRNAMT = 'CGEQPY' CALL CGEQPY( 1, M, N, 0, A, LDA, AQ, LDA, IWORK, $ IRCOND, ORCOND, RANK, SVLUES, WORK, LW, $ RWORK, INFO ) * * Compute norm(svd(a) - svd(r)) * RESULT( 8 ) = CQRT12( M, N, A, LDA, COPYS, WORK, $ LWORK, RWORK ) * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Test yGEQPY when JOB=2 * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Get a work copy of matrix A from COPYA. * CALL CLACPY( 'All', M, N, COPYA, LDA, A, LDA ) * * Set WORK to identity. * CALL CLASET( 'All', M, M, CZERO, CONE, AQ, LDA ) * * Compute the Rank-Revealing QR factorization of A * IF ( NB.LT.3 ) THEN LW = MAX( 1, 2*MNMIN+MAX(N,M) ) ELSE LW = MAX( 1, 2*MNMIN+NB*NB+NB*MAX(N,M) ) END IF SRNAMT = 'CGEQPY' CALL CGEQPY( 2, M, N, M, A, LDA, AQ, LDA, IWORK, $ IRCOND, ORCOND, RANK, SVLUES, WORK, LW, $ RWORK, INFO ) * * Compute norm(svd(a) - svd(r)) * RESULT( 9 ) = CQRT12( M, N, A, LDA, COPYS, WORK, $ LWORK, RWORK ) * * Compute norm( A*P - Q*R ) * RESULT( 10 ) = CRRT01( 'Conjugate Transpose', $ M, N, COPYA, LDA, IWORK, $ AQ, LDA, A, LDA, WORK, LWORK ) * * Compute norm( Q'*Q - Identity ) * RESULT( 11 ) = CRRT02( M, AQ, LDA, WORK, LWORK ) * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Test yGEQPY when JOB=3 * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Get a work copy of matrix A from COPYA. * CALL CLACPY( 'All', M, N, COPYA, LDA, A, LDA ) * * Set WORK to identity. * CALL CLASET( 'All', M, M, CZERO, CONE, AQ, LDA ) * * Compute the Rank-Revealing QR factorization of A * IF ( NB.LT.3 ) THEN LW = MAX( 1, 2*MNMIN+MAX(N,M) ) ELSE LW = MAX( 1, 2*MNMIN+NB*NB+NB*MAX(N,M) ) END IF SRNAMT = 'CGEQPY' CALL CGEQPY( 3, M, N, M, A, LDA, AQ, LDA, IWORK, $ IRCOND, ORCOND, RANK, SVLUES, WORK, LW, $ RWORK, INFO ) * * Compute norm(svd(a) - svd(r)) * RESULT( 12 ) = CQRT12( M, N, A, LDA, COPYS, WORK, $ LWORK, RWORK ) * * Compute norm( A*P - Q*R ) * RESULT( 13 ) = CRRT01( 'No transpose', M, N, $ COPYA, LDA, IWORK, $ AQ, LDA, A, LDA, WORK, LWORK ) * * Compute norm( Q'*Q - Identity ) * RESULT( 14 ) = CRRT02( M, AQ, LDA, WORK, LWORK ) * * * *-*-*-*-*-*-*-*-*-*-* * * Printing results * * *-*-*-*-*-*-*-*-*-*-* * * Print information about the tests that did not pass * the threshold. * DO 110 K = 8, 14 IF( RESULT( K ).GE.THRESH ) THEN IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) $ CALL ALAHD( NOUT, PATH ) WRITE( NOUT, FMT = 9999 ) 'CGEQPY', M, N, $ NB, IMODE, K, $ RESULT( K ) NFAIL = NFAIL + 1 END IF 110 CONTINUE NRUN = NRUN + 7 * 90 CONTINUE 60 CONTINUE 70 CONTINUE 80 CONTINUE * * Print a summary of the results. * CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) * 9999 FORMAT( 1x, a6, ' M =', I5, ', N =', I5, ', NB =', I4, $ ', type ', I2, ', test ', I2, ', ratio =', G12.5 ) * * End of CCHKRR * END SHAR_EOF fi # end of overwriting check if test -f 'cerrqp.f' then echo shar: will not over-write existing file "'cerrqp.f'" else cat << SHAR_EOF > 'cerrqp.f' SUBROUTINE CERRQP( PATH, NUNIT ) * * -- 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*3 PATH INTEGER NUNIT * .. * * Purpose * ======= * * CERRQP tests the error exits for CGEQPF. * * Arguments * ========= * * PATH (input) CHARACTER*3 * The LAPACK path name for the routines to be tested. * * NUNIT (input) INTEGER * The unit number for output. * * ===================================================================== * * .. Parameters .. INTEGER NMAX PARAMETER ( NMAX = 2 ) * .. * .. Local Scalars .. CHARACTER*2 C2 INTEGER INFO * .. * .. Local Arrays .. INTEGER IP( NMAX ) REAL RW( 2*NMAX ) COMPLEX A( NMAX, NMAX ), TAU( NMAX ), W( NMAX ) * .. * .. External Functions .. LOGICAL LSAMEN EXTERNAL LSAMEN * .. * .. External Subroutines .. EXTERNAL ALAESM, CGEQPF, CHKXER * .. * .. Scalars in Common .. LOGICAL LERR, OK CHARACTER*6 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. COMMON / INFOC / INFOT, NOUT, OK, LERR COMMON / SRNAMC / SRNAMT * .. * .. Intrinsic Functions .. INTRINSIC CMPLX * .. * .. Executable Statements .. * NOUT = NUNIT C2 = PATH( 2: 3 ) A( 1, 1 ) = CMPLX( 1., -1. ) A( 1, 2 ) = CMPLX( 2., -2. ) A( 2, 2 ) = CMPLX( 3., -3. ) A( 2, 1 ) = CMPLX( 4., -4. ) OK = .TRUE. WRITE( NOUT, FMT = * ) * * Test error exits for QR factorization with pivoting * IF( LSAMEN( 2, C2, 'QP' ) ) THEN * * CGEQPF * SRNAMT = 'CGEQPF' INFOT = 1 CALL CGEQPF( -1, 0, A, 1, IP, TAU, W, RW, INFO ) CALL CHKXER( 'CGEQPF', INFOT, NOUT, LERR, OK ) INFOT = 2 CALL CGEQPF( 0, -1, A, 1, IP, TAU, W, RW, INFO ) CALL CHKXER( 'CGEQPF', INFOT, NOUT, LERR, OK ) INFOT = 4 CALL CGEQPF( 2, 0, A, 1, IP, TAU, W, RW, INFO ) CALL CHKXER( 'CGEQPF', INFOT, NOUT, LERR, OK ) END IF * * Print a summary line. * CALL ALAESM( PATH, OK, NOUT ) * RETURN * * End of CERRQP * END SHAR_EOF fi # end of overwriting check if test -f 'cerrrr.f' then echo shar: will not over-write existing file "'cerrrr.f'" else cat << SHAR_EOF > 'cerrrr.f' SUBROUTINE CERRRR( PATH, NUNIT ) * * -- LAPACK test routine (version 1.0b) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * Rewritten for new least-squares solvers. * * .. Scalar Arguments .. CHARACTER*3 PATH INTEGER NUNIT * .. * * Purpose * ======= * * CERRRR tests the error exits for CGEQPX and CGEQPY. * * Arguments * ========= * * PATH (input) CHARACTER*3 * The LAPACK path name for the routines to be tested. * * NUNIT (input) INTEGER * The unit number for output. * * ===================================================================== * * .. Parameters .. INTEGER NMAX PARAMETER ( NMAX = 2 ) REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. CHARACTER*2 C2 INTEGER INFO, RANK, LW REAL IRCOND, ORCOND * .. * .. Local Arrays .. INTEGER IP( NMAX ) REAL SVLUES( 4 ), RW( 2*NMAX ) COMPLEX A( NMAX, NMAX ), C( NMAX, NMAX ), $ W( 2*NMAX+3*NMAX ) * .. * .. External Functions .. LOGICAL LSAMEN EXTERNAL LSAMEN * .. * .. External Subroutines .. EXTERNAL ALAESM, CHKXER, CGEQPX * .. * .. Scalars in Common .. LOGICAL LERR, OK CHARACTER*6 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. COMMON / INFOC / INFOT, NOUT, OK, LERR COMMON / SRNAMC / SRNAMT * .. * .. Executable Statements .. * IRCOND = ZERO RANK = 1 LW = 2*NMAX+3*NMAX NOUT = NUNIT WRITE( NOUT, FMT = * ) C2 = PATH( 2: 3 ) A( 1, 1 ) = ( 1.0E+0, 0.0E+0 ) A( 1, 2 ) = ( 2.0E+0, 0.0E+0 ) A( 2, 2 ) = ( 3.0E+0, 0.0E+0 ) A( 2, 1 ) = ( 4.0E+0, 0.0E+0 ) OK = .TRUE. * IF( LSAMEN( 2, C2, 'RR' ) ) THEN * * Test error exits for Rank-Revealing QR factorization * * CGEQPX * SRNAMT = 'CGEQPX' INFOT = 1 CALL CGEQPX( 4, 0, 0, 0, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, RW, INFO ) CALL CHKXER( 'CGEQPX', INFOT, NOUT, LERR, OK ) INFOT = 2 CALL CGEQPX( 1, -1, 0, 0, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, RW, INFO ) CALL CHKXER( 'CGEQPX', INFOT, NOUT, LERR, OK ) INFOT = 3 CALL CGEQPX( 1, 0, -1, 0, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, RW, INFO ) CALL CHKXER( 'CGEQPX', INFOT, NOUT, LERR, OK ) INFOT = 4 CALL CGEQPX( 1, 0, 0, -1, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, RW, INFO ) CALL CHKXER( 'CGEQPX', INFOT, NOUT, LERR, OK ) INFOT = 6 CALL CGEQPX( 1, 2, 0, 0, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, RW, INFO ) CALL CHKXER( 'CGEQPX', INFOT, NOUT, LERR, OK ) INFOT = 8 CALL CGEQPX( 2, 2, 0, 0, A, 2, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, RW, INFO ) CALL CHKXER( 'CGEQPX', INFOT, NOUT, LERR, OK ) INFOT = 10 CALL CGEQPX( 1, 0, 0, 0, A, 1, C, 1, IP, -ONE, ORCOND, $ RANK, SVLUES, W, LW, RW, INFO ) CALL CHKXER( 'CGEQPX', INFOT, NOUT, LERR, OK ) INFOT = 15 CALL CGEQPX( 1, 0, 3, 0, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, 2, RW, INFO ) CALL CHKXER( 'CGEQPX', INFOT, NOUT, LERR, OK ) * * CGEQPY * SRNAMT = 'CGEQPY' INFOT = 1 CALL CGEQPY( 4, 0, 0, 0, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, RW, INFO ) CALL CHKXER( 'CGEQPY', INFOT, NOUT, LERR, OK ) INFOT = 2 CALL CGEQPY( 1, -1, 0, 0, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, RW, INFO ) CALL CHKXER( 'CGEQPY', INFOT, NOUT, LERR, OK ) INFOT = 3 CALL CGEQPY( 1, 0, -1, 0, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, RW, INFO ) CALL CHKXER( 'CGEQPY', INFOT, NOUT, LERR, OK ) INFOT = 4 CALL CGEQPY( 1, 0, 0, -1, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, RW, INFO ) CALL CHKXER( 'CGEQPY', INFOT, NOUT, LERR, OK ) INFOT = 6 CALL CGEQPY( 1, 2, 0, 0, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, RW, INFO ) CALL CHKXER( 'CGEQPY', INFOT, NOUT, LERR, OK ) INFOT = 8 CALL CGEQPY( 2, 2, 0, 0, A, 2, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, RW, INFO ) CALL CHKXER( 'CGEQPY', INFOT, NOUT, LERR, OK ) INFOT = 10 CALL CGEQPY( 1, 0, 0, 0, A, 1, C, 1, IP, -ONE, ORCOND, $ RANK, SVLUES, W, LW, RW, INFO ) CALL CHKXER( 'CGEQPY', INFOT, NOUT, LERR, OK ) INFOT = 15 CALL CGEQPY( 1, 0, 3, 0, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, 2, RW, INFO ) CALL CHKXER( 'CGEQPY', INFOT, NOUT, LERR, OK ) END IF * * Print a summary line. * CALL ALAESM( PATH, OK, NOUT ) * RETURN * * End of CERRRR * END SHAR_EOF fi # end of overwriting check if test -f 'chkxer.f' then echo shar: will not over-write existing file "'chkxer.f'" else cat << SHAR_EOF > 'chkxer.f' SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) * * Tests whether XERBLA has detected an error when it should. * * Auxiliary routine for test program for Level 2 Blas. * * -- Written on 10-August-1987. * Richard Hanson, Sandia National Labs. * Jeremy Du Croz, NAG Central Office. * * ===================================================================== * * .. Scalar Arguments .. LOGICAL LERR, OK CHARACTER*6 SRNAMT INTEGER INFOT, NOUT * .. * .. Executable Statements .. IF( .NOT.LERR ) THEN WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT OK = .FALSE. END IF LERR = .FALSE. RETURN * 9999 FORMAT( ' *** Illegal value of parameter number ', I2, $ ' not detected by ', A6, ' ***' ) * * End of CHKXER. * END SHAR_EOF fi # end of overwriting check if test -f 'cqpt01.f' then echo shar: will not over-write existing file "'cqpt01.f'" else cat << SHAR_EOF > 'cqpt01.f' REAL FUNCTION CQPT01( M, N, K, A, AF, LDA, TAU, JPVT, $ WORK, LWORK ) * * -- 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 .. INTEGER K, LDA, LWORK, M, N * .. * .. Array Arguments .. INTEGER JPVT( * ) COMPLEX A( LDA, * ), AF( LDA, * ), TAU( * ), $ WORK( LWORK ) * .. * * Purpose * ======= * * CQPT01 tests the QR-factorization with pivoting of a matrix A. The * array AF contains the (possibly partial) QR-factorization of A, where * the upper triangle of AF(1:k,1:k) is a partial triangular factor, * the entries below the diagonal in the first k columns are the * Householder vectors, and the rest of AF contains a partially updated * matrix. * * This function returns ||A*P - Q*R||/(||norm(A)||*eps*M) * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrices A and AF. * * N (input) INTEGER * The number of columns of the matrices A and AF. * * K (input) INTEGER * The number of columns of AF that have been reduced * to upper triangular form. * * A (input) COMPLEX array, dimension (LDA, N) * The original matrix A. * * AF (input) COMPLEX array, dimension (LDA,N) * The (possibly partial) output of CGEQPF. The upper triangle * of AF(1:k,1:k) is a partial triangular factor, the entries * below the diagonal in the first k columns are the Householder * vectors, and the rest of AF contains a partially updated * matrix. * * LDA (input) INTEGER * The leading dimension of the arrays A and AF. * * TAU (input) COMPLEX array, dimension (K) * Details of the Householder transformations as returned by * CGEQPF. * * JPVT (input) INTEGER array, dimension (N) * Pivot information as returned by CGEQPF. * * WORK (workspace) COMPLEX array, dimension (LWORK) * * LWORK (input) INTEGER * The length of the array WORK. LWORK >= M*N+N. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) * .. * .. Local Scalars .. INTEGER I, INFO, J REAL NORMA * .. * .. Local Arrays .. REAL RWORK( 1 ) * .. * .. External Functions .. REAL CLANGE, SLAMCH EXTERNAL CLANGE, SLAMCH * .. * .. External Subroutines .. EXTERNAL CAXPY, CCOPY, CUNMQR, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CMPLX, MAX, MIN, REAL * .. * .. Executable Statements .. * CQPT01 = ZERO * * Test if there is enough workspace * IF( LWORK.LT.M*N+N ) THEN CALL XERBLA( 'CQPT01', 10 ) RETURN END IF * * Quick return if possible * IF( M.LE.0 .OR. N.LE.0 ) $ RETURN * NORMA = CLANGE( 'One-norm', M, N, A, LDA, RWORK ) * DO 30 J = 1, K DO 10 I = 1, MIN( J, M ) WORK( ( J-1 )*M+I ) = AF( I, J ) 10 CONTINUE DO 20 I = J + 1, M WORK( ( J-1 )*M+I ) = ZERO 20 CONTINUE 30 CONTINUE DO 40 J = K + 1, N CALL CCOPY( M, AF( 1, J ), 1, WORK( ( J-1 )*M+1 ), 1 ) 40 CONTINUE * CALL CUNMQR( 'Left', 'No transpose', M, N, K, AF, LDA, TAU, WORK, $ M, WORK( M*N+1 ), LWORK-M*N, INFO ) * DO 50 J = 1, N * * Compare i-th column of QR and jpvt(i)-th column of A * CALL CAXPY( M, CMPLX( -ONE ), A( 1, JPVT( J ) ), 1, $ WORK( ( J-1 )*M+1 ), 1 ) 50 CONTINUE * CQPT01 = CLANGE( 'One-norm', M, N, WORK, M, RWORK ) / $ ( REAL( MAX( M, N ) )*SLAMCH( 'Epsilon' ) ) IF( NORMA.NE.ZERO ) $ CQPT01 = CQPT01 / NORMA * RETURN * * End of CQPT01 * END SHAR_EOF fi # end of overwriting check if test -f 'cqrt11.f' then echo shar: will not over-write existing file "'cqrt11.f'" else cat << SHAR_EOF > 'cqrt11.f' REAL FUNCTION CQRT11( M, K, A, LDA, TAU, WORK, LWORK ) * * -- LAPACK 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 K, LDA, LWORK, M * .. * .. Array Arguments .. COMPLEX A( LDA, * ), TAU( * ), WORK( LWORK ) * .. * * Purpose * ======= * * CQRT11 computes the test ratio * * || Q'*Q - I || / (eps * m) * * where the orthogonal matrix Q is represented as a product of * elementary transformations. Each transformation has the form * * H(k) = I - tau(k) v(k) v(k)' * * where tau(k) is stored in TAU(k) and v(k) is an m-vector of the form * [ 0 ... 0 1 x(k) ]', where x(k) is a vector of length m-k stored * in A(k+1:m,k). * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. * * K (input) INTEGER * The number of columns of A whose subdiagonal entries * contain information about orthogonal transformations. * * A (input) COMPLEX array, dimension (LDA,K) * The (possibly partial) output of a QR reduction routine. * * LDA (input) INTEGER * The leading dimension of the array A. * * TAU (input) COMPLEX array, dimension (K) * The scaling factors tau for the elementary transformations as * computed by the QR factorization routine. * * WORK (workspace) COMPLEX array, dimension (LWORK) * * LWORK (input) INTEGER * The length of the array WORK. LWORK >= M*M + M. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) * .. * .. Local Scalars .. INTEGER INFO, J * .. * .. External Functions .. REAL CLANGE, SLAMCH EXTERNAL CLANGE, SLAMCH * .. * .. External Subroutines .. EXTERNAL CLASET, CUNM2R, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CMPLX, REAL * .. * .. Local Arrays .. REAL RDUMMY( 1 ) * .. * .. Executable Statements .. * CQRT11 = ZERO * * Test for sufficient workspace * IF( LWORK.LT.M*M+M ) THEN CALL XERBLA( 'CQRT11', 7 ) RETURN END IF * * Quick return if possible * IF( M.LE.0 ) $ RETURN * CALL CLASET( 'Full', M, M, CMPLX( ZERO ), CMPLX( ONE ), WORK, M ) * * Form Q * CALL CUNM2R( 'Left', 'No transpose', M, M, K, A, LDA, TAU, WORK, $ M, WORK( M*M+1 ), INFO ) * * Form Q'*Q * CALL CUNM2R( 'Left', 'Conjugate transpose', M, M, K, A, LDA, TAU, $ WORK, M, WORK( M*M+1 ), INFO ) * DO 10 J = 1, M WORK( ( J-1 )*M+J ) = WORK( ( J-1 )*M+J ) - ONE 10 CONTINUE * CQRT11 = CLANGE( 'One-norm', M, M, WORK, M, RDUMMY ) / $ ( REAL( M )*SLAMCH( 'Epsilon' ) ) * RETURN * * End of CQRT11 * END SHAR_EOF fi # end of overwriting check if test -f 'cqrt12.f' then echo shar: will not over-write existing file "'cqrt12.f'" else cat << SHAR_EOF > 'cqrt12.f' REAL FUNCTION CQRT12( M, N, A, LDA, S, WORK, LWORK, $ RWORK ) * * -- 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 .. INTEGER LDA, LWORK, M, N * .. * .. Array Arguments .. REAL RWORK( * ), S( * ) COMPLEX A( LDA, * ), WORK( LWORK ) * .. * * Purpose * ======= * * CQRT12 computes the singular values 'svlues' of the upper trapezoid * of A(1:M,1:N) and returns the ratio * * || s - svlues||/(||svlues||*eps*max(M,N)) * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. * * N (input) INTEGER * The number of columns of the matrix A. * * A (input) COMPLEX array, dimension (LDA,N) * The M-by-N matrix A. Only the upper trapezoid is referenced. * * LDA (input) INTEGER * The leading dimension of the array A. * * S (input) REAL array, dimension (min(M,N)) * The singular values of the matrix A. * * WORK (workspace) COMPLEX array, dimension (LWORK) * * LWORK (input) INTEGER * The length of the array WORK. LWORK >= M*N + 2*min(M,N) + * max(M,N). * * RWORK (workspace) REAL array, dimension (4*min(M,N)) * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) * .. * .. Local Scalars .. INTEGER I, INFO, ISCL, J, MN REAL ANRM, BIGNUM, NRMSVL, SMLNUM * .. * .. Local Arrays .. REAL DUMMY( 1 ) * .. * .. External Functions .. REAL CLANGE, SASUM, SLAMCH, SNRM2 EXTERNAL CLANGE, SASUM, SLAMCH, SNRM2 * .. * .. External Subroutines .. EXTERNAL CGEBD2, CLASCL, CLASET, SAXPY, SBDSQR, SLABAD, $ SLASCL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CMPLX, MAX, MIN, REAL * .. * .. Executable Statements .. * CQRT12 = ZERO * * Test that enough workspace is supplied * IF( LWORK.LT.M*N+2*MIN( M, N )+MAX( M, N ) ) THEN CALL XERBLA( 'CQRT12', 7 ) RETURN END IF * * Quick return if possible * MN = MIN( M, N ) IF( MN.LE.ZERO ) $ RETURN * NRMSVL = SNRM2( MN, S, 1 ) * * Copy upper triangle of A into work * CALL CLASET( 'Full', M, N, CMPLX( ZERO ), CMPLX( ZERO ), WORK, M ) DO 20 J = 1, N DO 10 I = 1, MIN( J, M ) WORK( ( J-1 )*M+I ) = A( I, J ) 10 CONTINUE 20 CONTINUE * * Get machine parameters * SMLNUM = SLAMCH( 'S' ) / SLAMCH( 'P' ) BIGNUM = ONE / SMLNUM CALL SLABAD( SMLNUM, BIGNUM ) * * Scale work if max entry outside range [SMLNUM,BIGNUM] * ANRM = CLANGE( 'M', M, N, WORK, M, DUMMY ) ISCL = 0 IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN * * Scale matrix norm up to SMLNUM * CALL CLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, WORK, M, INFO ) ISCL = 1 ELSE IF( ANRM.GT.BIGNUM ) THEN * * Scale matrix norm down to BIGNUM * CALL CLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, WORK, M, INFO ) ISCL = 1 END IF * IF( ANRM.NE.ZERO ) THEN * * Compute SVD of work * CALL CGEBD2( M, N, WORK, M, RWORK( 1 ), RWORK( MN+1 ), $ WORK( M*N+1 ), WORK( M*N+MN+1 ), $ WORK( M*N+2*MN+1 ), INFO ) CALL SBDSQR( 'Upper', MN, 0, 0, 0, RWORK( 1 ), RWORK( MN+1 ), $ DUMMY, MN, DUMMY, 1, DUMMY, MN, RWORK( 2*MN+1 ), $ INFO ) * IF( ISCL.EQ.1 ) THEN IF( ANRM.GT.BIGNUM ) THEN CALL SLASCL( 'G', 0, 0, BIGNUM, ANRM, MN, 1, RWORK( 1 ), $ MN, INFO ) END IF IF( ANRM.LT.SMLNUM ) THEN CALL SLASCL( 'G', 0, 0, SMLNUM, ANRM, MN, 1, RWORK( 1 ), $ MN, INFO ) END IF END IF * ELSE * DO 30 I = 1, MN RWORK( I ) = ZERO 30 CONTINUE END IF * * Compare s and singular values of work * CALL SAXPY( MN, -ONE, S, 1, RWORK( 1 ), 1 ) CQRT12 = SASUM( MN, RWORK( 1 ), 1 ) / $ ( SLAMCH( 'Epsilon' )*REAL( MAX( M, N ) ) ) IF( NRMSVL.NE.ZERO ) $ CQRT12 = CQRT12 / NRMSVL * RETURN * * End of CQRT12 * END SHAR_EOF fi # end of overwriting check if test -f 'crrt01.f' then echo shar: will not over-write existing file "'crrt01.f'" else cat << SHAR_EOF > 'crrt01.f' REAL FUNCTION CRRT01( CNJTRN, M, N, A, LDA, JPVT, $ Q, LDQ, R, LDR, WORK, LWORK ) * * * * .. Scalar Arguments .. CHARACTER*1 CNJTRN INTEGER M, N, LDA, LDQ, LDR, LWORK * .. * .. Array Arguments .. INTEGER JPVT( * ) COMPLEX A( LDA, * ), Q( LDQ, * ), R( LDR, * ), $ WORK( LWORK ) * .. * * Purpose * ======= * * CRRT01 tests the Rank-Revealing QR-factorization of matrix A. * Array A contains the original matrix being factorized. * Argument TRANS says if array Q contains matrix Q or its conjugate * transpose. * Array R contains matrix R. * * This function returns ||A*P - Q*R||/(||norm(A)||*eps*M) * * Arguments * ========= * * TRANS (input) CHARACTER*1 * If TRANS='N', then array Q contains matrix Q. * If TRANS='T', then array Q contains the conjugate transpose * of matrix Q. * * M (input) INTEGER * Number of rows of matrices A, R and Q, * and number of columns of Q. * * N (input) INTEGER * Number of columns of matrices A and R. * * A (input) COMPLEX array, dimension (LDA, N) * Original m by n matrix A. * * JPVT (input) INTEGER array, dimension (N) * Pivot information as returned by CGERQR. * * Q (input) COMPLEX array, dimension (LDQ,M) * Array which contains m by m orthogonal matrix Q * or its tranpose, according argument TRANS. * * R (input) COMPLEX array, dimension (LDR,N) * Upper triangular matrix. * The lower part of matrix R must contain zeroes. * * LDR (input) INTEGER * Leading dimension of arrays A and R. * * WORK (workspace) COMPLEX array, dimension (LWORK) * * LWORK (input) INTEGER * Length of array WORK. LWORK >= M*N. * * .. Parameters .. REAL ZERO, ONE COMPLEX CZERO, CONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, $ CZERO = ( 0.0E+0, 0.0E+0 ), $ CONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. INTEGER LDWORK, J REAL NORMA * .. * .. Local Arrays .. REAL RDUMMY( 1 ) * .. * .. External Functions .. LOGICAL LSAME REAL SLAMCH, CLANGE EXTERNAL LSAME, SLAMCH, SLANGE * .. * .. External Subroutines .. EXTERNAL CCOPY, XERBLA, CGEMM * .. * .. Intrinsic Functions .. INTRINSIC MAX, REAL * .. * .. Executable Statements .. * LDWORK = MAX( 1, M ) * * Test if there is enough workspace * IF( LWORK.LT.M*N ) THEN CALL XERBLA( 'CRRT01', 10 ) RETURN END IF * * Quick return if possible * IF( M.LE.0 .OR. N.LE.0 ) THEN CRRT01 = ZERO RETURN END IF * NORMA = CLANGE( 'One-norm', M, N, A, LDA, RDUMMY ) * * Compute WORK := A*P. * DO J = 1, N CALL CCOPY( M, A( 1, JPVT( J ) ), 1, $ WORK( (J-1)*M+1 ), 1 ) END DO * * Compute WORK := WORK - Q*R. * IF( LSAME( CNJTRN, 'N' ) ) THEN CALL CGEMM( 'No transpose', 'No transpose', M, N, M, $ -CONE, Q, LDQ, R, LDR, CONE, WORK, LDWORK ) ELSE CALL CGEMM( 'Conjugate transpose', 'No transpose', $ M, N, M, -CONE, Q, LDQ, R, LDR, CONE, $ WORK, LDWORK ) END IF * * Compute the 1-norm of WORK divided by (max(m,n)*eps). * CRRT01 = CLANGE( 'One-norm', M, N, WORK, LDWORK, $ RDUMMY ) / $ ( REAL( MAX( M, N ) )*SLAMCH( 'Epsilon' ) ) IF( NORMA.NE.ZERO ) $ CRRT01 = CRRT01 / NORMA * RETURN * * End of CRRT01 * END SHAR_EOF fi # end of overwriting check if test -f 'crrt02.f' then echo shar: will not over-write existing file "'crrt02.f'" else cat << SHAR_EOF > 'crrt02.f' REAL FUNCTION CRRT02( M, QT, LDQT, WORK, LWORK ) * * * * .. Scalar Arguments .. INTEGER M, LDQT, LWORK * .. * .. Array Arguments .. COMPLEX QT( LDQT, * ), WORK( LWORK ) * .. * * Purpose * ======= * * CRRT02 computes the test ratio * * || Q'*Q - I || / (eps * m) * * where the transpose of matrix Q (Q') is stored in array QT. * * * Arguments * ========= * * M (input) INTEGER * Number of rows and columns of matrix QT. * * QT (input) COMPLEX array, dimension (LDQT,N) * Transpose of m by m matrix Q. * * LDQT (input) INTEGER * Leading dimension of array QT. * * WORK (workspace) COMPLEX array, dimension (LWORK) * * LWORK (input) INTEGER * The length of the array WORK. LWORK >= M*M. * * .. Parameters .. REAL ZERO, ONE COMPLEX CZERO, CONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, $ CZERO = ( 0.0E+0, 0.0E+0 ), $ CONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. INTEGER LDWORK * .. * .. External Functions .. REAL SLAMCH, CLANGE EXTERNAL SLAMCH, CLANGE * .. * .. External Subroutines .. EXTERNAL CLASET, XERBLA, CGEMM * .. * .. Intrinsic Functions .. INTRINSIC MAX, REAL * .. * .. Local Arrays .. REAL RDUMMY( 1 ) * .. * .. Executable Statements .. * LDWORK = MAX( 1, M ) * * Test for sufficient workspace. * IF( LWORK.LT.M*M ) THEN CALL XERBLA( 'CRRT02', 7 ) RETURN END IF * * Quick return if possible. * IF( M.LE.0 ) THEN CRRT02 = ZERO RETURN END IF * * Set WORK to the identity. * CALL CLASET( 'All', M, M, CZERO, CONE, WORK, LDWORK ) * * Compute WORK := WORK - QT * QT'. That is, WORK := WORK - Q'*Q. * CALL CGEMM( 'No transpose', 'Conjugate transpose', $ M, M, M, -CONE, QT, LDQT, QT, LDQT, CONE, $ WORK, LDWORK ) * * Compute || WORK || / ( m * eps ). * CRRT02 = CLANGE( 'One-norm', M, M, WORK, LDWORK, $ RDUMMY ) / $ ( REAL( M )*SLAMCH( 'Epsilon' ) ) * RETURN * * End of CRRT02 * END SHAR_EOF fi # end of overwriting check if test -f 'dchkaa.f' then echo shar: will not over-write existing file "'dchkaa.f'" else cat << SHAR_EOF > 'dchkaa.f' PROGRAM DCHKAA * * -- 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 * * Purpose * ======= * * DCHKAA is the main test program for the DOUBLE PRECISION LAPACK * linear equation routines * * An annotated example of a data file can be obtained by deleting the * first 3 characters from the following lines: * Data file for testing DOUBLE PRECISION LAPACK linear eqn. routines * 7 Number of values of M * 0 1 2 3 5 10 16 Values of M (row dimension) * 7 Number of values of N * 0 1 2 3 5 10 16 Values of N (column dimension) * 5 Number of values of NB * 1 3 3 3 20 Values of NB (the blocksize) * 1 0 5 9 1 Values of NX (crossover point) * 20.0 Threshold value of test ratio * T Put T to test the LAPACK routines * T Put T to test the driver routines * T Put T to test the error exits * DQP 6 List types on next line if 0 < NTYPES < 6 * DRR 3 List types on next line if 0 < NTYPES < 3 * * Internal Parameters * =================== * * NMAX INTEGER * The maximum allowable value for N * * MAXIN INTEGER * The number of different values that can be used for each of * M, N, NB, and NX * * MAXRHS INTEGER * The maximum number of right hand sides * * NIN INTEGER * The unit number for input * * NOUT INTEGER * The unit number for output * * LWORK INTEGER * The workspace length * * ===================================================================== * * .. Parameters .. INTEGER NMAX PARAMETER ( NMAX = 501 ) INTEGER MAXIN PARAMETER ( MAXIN = 12 ) INTEGER MAXRHS PARAMETER ( MAXRHS = 10 ) INTEGER MATMAX PARAMETER ( MATMAX = 30 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER KDMAX PARAMETER ( KDMAX = NMAX+( NMAX+1 ) / 4 ) * INTEGER LWORK PARAMETER ( LWORK = NMAX*( NMAX+MAXRHS+5 ) ) * .. * .. Local Scalars .. LOGICAL FATAL, TSTCHK, TSTERR CHARACTER C1 CHARACTER*2 C2 CHARACTER*3 PATH CHARACTER*10 INTSTR CHARACTER*72 ALINE INTEGER I, IC, J, K, LDA, NB, NM, NMATS, NN, $ NNB, NNB2, NTYPES DOUBLE PRECISION EPS, S1, S2, THREQ, THRESH * .. * .. Local Arrays .. LOGICAL DOTYPE( MATMAX ) INTEGER IWORK( 3*NMAX ), MVAL( MAXIN ), NBVAL( MAXIN ), $ NBVAL2( MAXIN ), NVAL( MAXIN ), NXVAL( MAXIN ) DOUBLE PRECISION A( ( KDMAX+1 )*NMAX, 7 ), B( NMAX*MAXRHS, 4 ), $ WORK( NMAX, NMAX+MAXRHS+5 ) * .. * .. External Functions .. LOGICAL LSAME, LSAMEN DOUBLE PRECISION DLAMCH, DSECND EXTERNAL LSAME, LSAMEN, DLAMCH, DSECND * .. * .. External Subroutines .. EXTERNAL ALAREQ, DCHKQP, DCHKRR * .. * .. Scalars in Common .. LOGICAL LERR, OK CHARACTER*6 SRNAMT INTEGER INFOT, NUNIT * .. * .. Arrays in Common .. INTEGER IPARMS( 100 ) * .. * .. Common blocks .. COMMON / INFOC / INFOT, NUNIT, OK, LERR COMMON / SRNAMC / SRNAMT COMMON / CLAENV / IPARMS * .. * .. Data statements .. DATA THREQ / 2.0D0 / , INTSTR / '0123456789' / * .. * .. Executable Statements .. * S1 = DSECND( ) LDA = NMAX FATAL = .FALSE. * * Read a dummy line. * READ( NIN, FMT = * ) * * Report values of parameters. * WRITE( NOUT, FMT = 9994 ) * * Read the values of M * READ( NIN, FMT = * )NM IF( NM.LT.1 ) THEN WRITE( NOUT, FMT = 9996 )' NM ', NM, 1 NM = 0 FATAL = .TRUE. ELSE IF( NM.GT.MAXIN ) THEN WRITE( NOUT, FMT = 9995 )' NM ', NM, MAXIN NM = 0 FATAL = .TRUE. END IF READ( NIN, FMT = * )( MVAL( I ), I = 1, NM ) DO 10 I = 1, NM IF( MVAL( I ).LT.0 ) THEN WRITE( NOUT, FMT = 9996 )' M ', MVAL( I ), 0 FATAL = .TRUE. ELSE IF( MVAL( I ).GT.NMAX ) THEN WRITE( NOUT, FMT = 9995 )' M ', MVAL( I ), NMAX FATAL = .TRUE. END IF 10 CONTINUE IF( NM.GT.0 ) $ WRITE( NOUT, FMT = 9993 )'M ', ( MVAL( I ), I = 1, NM ) * * Read the values of N * READ( NIN, FMT = * )NN IF( NN.LT.1 ) THEN WRITE( NOUT, FMT = 9996 )' NN ', NN, 1 NN = 0 FATAL = .TRUE. ELSE IF( NN.GT.MAXIN ) THEN WRITE( NOUT, FMT = 9995 )' NN ', NN, MAXIN NN = 0 FATAL = .TRUE. END IF READ( NIN, FMT = * )( NVAL( I ), I = 1, NN ) DO 20 I = 1, NN IF( NVAL( I ).LT.0 ) THEN WRITE( NOUT, FMT = 9996 )' N ', NVAL( I ), 0 FATAL = .TRUE. ELSE IF( NVAL( I ).GT.NMAX ) THEN WRITE( NOUT, FMT = 9995 )' N ', NVAL( I ), NMAX FATAL = .TRUE. END IF 20 CONTINUE IF( NN.GT.0 ) $ WRITE( NOUT, FMT = 9993 )'N ', ( NVAL( I ), I = 1, NN ) * * Read the values of NB * READ( NIN, FMT = * )NNB IF( NNB.LT.1 ) THEN WRITE( NOUT, FMT = 9996 )'NNB ', NNB, 1 NNB = 0 FATAL = .TRUE. ELSE IF( NNB.GT.MAXIN ) THEN WRITE( NOUT, FMT = 9995 )'NNB ', NNB, MAXIN NNB = 0 FATAL = .TRUE. END IF READ( NIN, FMT = * )( NBVAL( I ), I = 1, NNB ) DO 40 I = 1, NNB IF( NBVAL( I ).LT.0 ) THEN WRITE( NOUT, FMT = 9996 )' NB ', NBVAL( I ), 0 FATAL = .TRUE. END IF 40 CONTINUE IF( NNB.GT.0 ) $ WRITE( NOUT, FMT = 9993 )'NB ', ( NBVAL( I ), I = 1, NNB ) * * Set NBVAL2 to be the set of unique values of NB * NNB2 = 0 DO 60 I = 1, NNB NB = NBVAL( I ) DO 50 J = 1, NNB2 IF( NB.EQ.NBVAL2( J ) ) $ GO TO 60 50 CONTINUE NNB2 = NNB2 + 1 NBVAL2( NNB2 ) = NB 60 CONTINUE * * Read the values of NX * READ( NIN, FMT = * )( NXVAL( I ), I = 1, NNB ) DO 70 I = 1, NNB IF( NXVAL( I ).LT.0 ) THEN WRITE( NOUT, FMT = 9996 )' NX ', NXVAL( I ), 0 FATAL = .TRUE. END IF 70 CONTINUE IF( NNB.GT.0 ) $ WRITE( NOUT, FMT = 9993 )'NX ', ( NXVAL( I ), I = 1, NNB ) * * Read the threshold value for the test ratios. * READ( NIN, FMT = * )THRESH WRITE( NOUT, FMT = 9992 )THRESH * * Read the flag that indicates whether to test the LAPACK routines. * READ( NIN, FMT = * )TSTCHK * * Read the flag that indicates whether to test the error exits. * READ( NIN, FMT = * )TSTERR * IF( FATAL ) THEN WRITE( NOUT, FMT = 9999 ) STOP END IF * * Calculate and print the machine dependent constants. * EPS = DLAMCH( 'Underflow threshold' ) WRITE( NOUT, FMT = 9991 )'underflow', EPS EPS = DLAMCH( 'Overflow threshold' ) WRITE( NOUT, FMT = 9991 )'overflow ', EPS EPS = DLAMCH( 'Epsilon' ) WRITE( NOUT, FMT = 9991 )'precision', EPS WRITE( NOUT, FMT = * ) * 80 CONTINUE * * Read a test path and the number of matrix types to use. * READ( NIN, FMT = '(A72)', END = 140 )ALINE PATH = ALINE( 1: 3 ) NMATS = MATMAX I = 3 90 CONTINUE I = I + 1 IF( I.GT.72 ) THEN NMATS = MATMAX GO TO 130 END IF IF( ALINE( I: I ).EQ.' ' ) $ GO TO 90 NMATS = 0 100 CONTINUE C1 = ALINE( I: I ) DO 110 K = 1, 10 IF( C1.EQ.INTSTR( K: K ) ) THEN IC = K - 1 GO TO 120 END IF 110 CONTINUE GO TO 130 120 CONTINUE NMATS = NMATS*10 + IC I = I + 1 IF( I.GT.72 ) $ GO TO 130 GO TO 100 130 CONTINUE C1 = PATH( 1: 1 ) C2 = PATH( 2: 3 ) * * Check first character for correct precision. * IF( .NOT.LSAME( C1, 'D precision' ) ) THEN WRITE( NOUT, FMT = 9990 )PATH * ELSE IF( NMATS.LE.0 ) THEN * * Check for a positive number of tests requested. * WRITE( NOUT, FMT = 9989 )PATH * ELSE IF( LSAMEN( 2, C2, 'QP' ) ) THEN * * QP: QR factorization with pivoting * NTYPES = 6 CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) * IF( TSTCHK ) THEN CALL DCHKQP( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, $ A( 1, 1 ), A( 1, 2 ), B( 1, 1 ), B( 1, 2 ), $ B( 1, 3 ), WORK, IWORK, NOUT ) ELSE WRITE( NOUT, FMT = 9989 )PATH END IF * ELSE IF( LSAMEN( 2, C2, 'RR' ) ) THEN * * RR: Rank-Revealing QR factorization * NTYPES = 3 CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) * IF( TSTCHK ) THEN CALL DCHKRR( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, $ NXVAL, THRESH, TSTERR, A( 1, 1 ), A( 1, 2 ), $ A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), $ WORK, LWORK, IWORK, NOUT ) ELSE WRITE( NOUT, FMT = 9989 )PATH END IF * ELSE * WRITE( NOUT, FMT = 9990 )PATH END IF * * Go back to get another input line. * GO TO 80 * * Branch to this line when the last record is read. * 140 CONTINUE CLOSE ( NIN ) S2 = DSECND( ) WRITE( NOUT, FMT = 9998 ) WRITE( NOUT, FMT = 9997 )S2 - S1 * 9999 FORMAT( / ' Execution not attempted due to input errors' ) 9998 FORMAT( / ' End of tests' ) 9997 FORMAT( ' Total time used = ', F12.2, ' seconds', / ) 9996 FORMAT( ' Invalid input value: ', A4, '=', I6, '; must be >=', $ I6 ) 9995 FORMAT( ' Invalid input value: ', A4, '=', I6, '; must be <=', $ I6 ) 9994 FORMAT( ' RRQR Tests. DOUBLE PRECISION routines ', $ / / ' The following parameter values will be used:' ) 9993 FORMAT( 4X, A4, ': ', 10I6, / 11X, 10I6 ) 9992 FORMAT( / ' Routines pass computational tests if test ratio is ', $ 'less than', F8.2, / ) 9991 FORMAT( ' Relative machine ', A, ' is taken to be', D16.6 ) 9990 FORMAT( / 1X, A3, ': Unrecognized path name' ) 9989 FORMAT( / 1X, A3, ' routines were not tested' ) 9988 FORMAT( / 1X, A3, ' driver routines were not tested' ) * * End of DCHKAA * END SHAR_EOF fi # end of overwriting check if test -f 'dchkqp.f' then echo shar: will not over-write existing file "'dchkqp.f'" else cat << SHAR_EOF > 'dchkqp.f' SUBROUTINE DCHKQP( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A, $ COPYA, S, COPYS, TAU, WORK, IWORK, NOUT ) * * -- 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 .. LOGICAL TSTERR INTEGER NM, NN, NOUT DOUBLE PRECISION THRESH * .. * .. Array Arguments .. LOGICAL DOTYPE( * ) INTEGER IWORK( * ), MVAL( * ), NVAL( * ) DOUBLE PRECISION A( * ), COPYA( * ), COPYS( * ), S( * ), $ TAU( * ), WORK( * ) * .. * * Purpose * ======= * * DCHKQP tests DGEQPF. * * Arguments * ========= * * DOTYPE (input) LOGICAL array, dimension (NTYPES) * The matrix types to be used for testing. Matrices of type j * (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = * .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. * * NM (input) INTEGER * The number of values of M contained in the vector MVAL. * * MVAL (input) INTEGER array, dimension (NM) * The values of the matrix row dimension M. * * NN (input) INTEGER * The number of values of N contained in the vector NVAL. * * NVAL (input) INTEGER array, dimension (NN) * The values of the matrix column dimension N. * * THRESH (input) DOUBLE PRECISION * The threshold value for the test ratios. A result is * included in the output file if RESULT >= THRESH. To have * every test ratio printed, use THRESH = 0. * * TSTERR (input) LOGICAL * Flag that indicates whether error exits are to be tested. * * A (workspace) DOUBLE PRECISION array, dimension (MMAX*NMAX) * where MMAX is the maximum value of M in MVAL and NMAX is the * maximum value of N in NVAL. * * COPYA (workspace) DOUBLE PRECISION array, dimension (MMAX*NMAX) * * S (workspace) DOUBLE PRECISION array, dimension * (min(MMAX,NMAX)) * * COPYS (workspace) DOUBLE PRECISION array, dimension * (min(MMAX,NMAX)) * * TAU (workspace) DOUBLE PRECISION array, dimension (MMAX) * * WORK (workspace) DOUBLE PRECISION array, dimension * (MMAX*NMAX + 4*NMAX + MMAX) * * IWORK (workspace) INTEGER array, dimension (NMAX) * * NOUT (input) INTEGER * The unit number for output. * * ===================================================================== * * .. Parameters .. INTEGER NTYPES PARAMETER ( NTYPES = 6 ) INTEGER NTESTS PARAMETER ( NTESTS = 3 ) DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) * .. * .. Local Scalars .. CHARACTER*3 PATH INTEGER I, IHIGH, ILOW, IM, IMODE, IN, INFO, ISTEP, K, $ LDA, LWORK, M, MNMIN, MODE, N, NERRS, NFAIL, $ NRUN DOUBLE PRECISION EPS * .. * .. Local Arrays .. INTEGER ISEED( 4 ), ISEEDY( 4 ) DOUBLE PRECISION RESULT( NTESTS ) * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DQPT01, DQRT11, DQRT12 EXTERNAL DLAMCH, DQPT01, DQRT11, DQRT12 * .. * .. External Subroutines .. EXTERNAL ALAHD, ALASUM, DERRQP, DGEQPF, DLACPY, DLAORD, $ DLASET, DLATMS * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Scalars in Common .. LOGICAL LERR, OK CHARACTER*6 SRNAMT INTEGER INFOT, IOUNIT * .. * .. Common blocks .. COMMON / INFOC / INFOT, IOUNIT, OK, LERR COMMON / SRNAMC / SRNAMT * .. * .. Data statements .. DATA ISEEDY / 1988, 1989, 1990, 1991 / * .. * .. Executable Statements .. * * Initialize constants and the random number seed. * PATH( 1: 1 ) = 'D' PATH( 2: 3 ) = 'QP' NRUN = 0 NFAIL = 0 NERRS = 0 DO 10 I = 1, 4 ISEED( I ) = ISEEDY( I ) 10 CONTINUE EPS = DLAMCH( 'Epsilon' ) * * Test the error exits * IF( TSTERR ) $ CALL DERRQP( PATH, NOUT ) INFOT = 0 * DO 80 IM = 1, NM * * Do for each value of M in MVAL. * M = MVAL( IM ) LDA = MAX( 1, M ) * DO 70 IN = 1, NN * * Do for each value of N in NVAL. * N = NVAL( IN ) MNMIN = MIN( M, N ) LWORK = MAX( 1, M*MAX( M, N )+4*MNMIN+MAX( M, N ) ) * DO 60 IMODE = 1, NTYPES IF( .NOT.DOTYPE( IMODE ) ) $ GO TO 60 * * Do for each type of matrix * 1: zero matrix * 2: one small singular value * 3: geometric distribution of singular values * 4: first n/2 columns fixed * 5: last n/2 columns fixed * 6: every second column fixed * MODE = IMODE IF( IMODE.GT.3 ) $ MODE = 1 * * Generate test matrix of size m by n using * singular value distribution indicated by 'mode'. * DO 20 I = 1, N IWORK( I ) = 0 20 CONTINUE IF( IMODE.EQ.1 ) THEN CALL DLASET( 'Full', M, N, ZERO, ZERO, COPYA, LDA ) DO 30 I = 1, MNMIN COPYS( I ) = ZERO 30 CONTINUE ELSE CALL DLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', COPYS, $ MODE, ONE / EPS, ONE, M, N, 'No packing', $ COPYA, LDA, WORK, INFO ) IF( IMODE.GE.4 ) THEN IF( IMODE.EQ.4 ) THEN ILOW = 1 ISTEP = 1 IHIGH = MAX( 1, N / 2 ) ELSE IF( IMODE.EQ.5 ) THEN ILOW = MAX( 1, N / 2 ) ISTEP = 1 IHIGH = N ELSE IF( IMODE.EQ.6 ) THEN ILOW = 1 ISTEP = 2 IHIGH = N END IF DO 40 I = ILOW, IHIGH, ISTEP IWORK( I ) = 1 40 CONTINUE END IF CALL DLAORD( 'Decreasing', MNMIN, COPYS, 1 ) END IF * * Save A and its singular values * CALL DLACPY( 'All', M, N, COPYA, LDA, A, LDA ) * * Compute the QR factorization with pivoting of A * SRNAMT = 'DGEQPF' CALL DGEQPF( M, N, A, LDA, IWORK, TAU, WORK, INFO ) * * Compute norm(svd(a) - svd(r)) * RESULT( 1 ) = DQRT12( M, N, A, LDA, COPYS, WORK, LWORK ) * * Compute norm( A*P - Q*R ) * RESULT( 2 ) = DQPT01( M, N, MNMIN, COPYA, A, LDA, TAU, $ IWORK, WORK, LWORK ) * * Compute Q'*Q * RESULT( 3 ) = DQRT11( M, MNMIN, A, LDA, TAU, WORK, $ LWORK ) * * Print information about the tests that did not pass * the threshold. * DO 50 K = 1, 3 IF( RESULT( K ).GE.THRESH ) THEN IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) $ CALL ALAHD( NOUT, PATH ) WRITE( NOUT, FMT = 9999 )M, N, IMODE, K, $ RESULT( K ) NFAIL = NFAIL + 1 END IF 50 CONTINUE NRUN = NRUN + 3 60 CONTINUE 70 CONTINUE 80 CONTINUE * * Print a summary of the results. * CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) * 9999 FORMAT( ' M =', I5, ', N =', I5, ', type ', I2, ', test ', I2, $ ', ratio =', G12.5 ) * * End if DCHKQP * END SHAR_EOF fi # end of overwriting check if test -f 'dchkrr.f' then echo shar: will not over-write existing file "'dchkrr.f'" else cat << SHAR_EOF > 'dchkrr.f' SUBROUTINE DCHKRR( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, $ NXVAL, THRESH, TSTERR, A, AQ, COPYA, S, COPYS, $ WORK, LNWK, IWORK, NOUT ) * * -- 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 * * Rewritten to test the new RRQR Subroutines. * * * .. Scalar Arguments .. LOGICAL TSTERR INTEGER LNWK, NM, NN, NNB, NOUT DOUBLE PRECISION THRESH * .. * .. Array Arguments .. LOGICAL DOTYPE( * ) INTEGER IWORK( * ), MVAL( * ), NVAL( * ), $ NBVAL( * ), NXVAL( * ) DOUBLE PRECISION A( * ), AQ( * ), COPYA( * ), $ COPYS( * ), S( * ), WORK( LNWK ) * .. * * Purpose * ======= * * DCHKRR tests DGEQPX and DGEQPY. * * Arguments * ========= * * DOTYPE (input) LOGICAL array, dimension (NTYPES) * The matrix types to be used for testing. Matrices of type j * (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = * .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. * * NM (input) INTEGER * The number of values of M contained in the vector MVAL. * * MVAL (input) INTEGER array, dimension (NM) * The values of the matrix row dimension M. * * NN (input) INTEGER * The number of values of N contained in the vector NVAL. * * NVAL (input) INTEGER array, dimension (NN) * The values of the matrix column dimension N. * * NNB (input) INTEGER * The number of values of NB and NX contained in the * vectors NBVAL and NXVAL. The blocking parameters are used * in pairs (NB,NX). * * NBVAL (input) INTEGER array, dimension (NNB) * The values of the blocksize NB. * * NXVAL (input) INTEGER array, dimension (NNB) * The values of the crossover point NX. * * THRESH (input) DOUBLE PRECISION * The threshold value for the test ratios. A result is * included in the output file if RESULT >= THRESH. To have * every test ratio printed, use THRESH = 0. * * TSTERR (input) LOGICAL * Flag that indicates whether error exits are to be tested. * * A (workspace) DOUBLE PRECISION array, dimension (MMAX*NMAX) * where MMAX is the maximum value of M in MVAL and NMAX is the * maximum value of N in NVAL. * * AQ (workspace) DOUBLE PRECISION array, dimension (MMAX*NMAX) * where MMAX is the maximum value of M in MVAL and NMAX is the * maximum value of N in NVAL. * * COPYA (workspace) DOUBLE PRECISION array, dimension (MMAX*NMAX) * * S (workspace) DOUBLE PRECISION array, dimension * (min(MMAX,NMAX)) * * COPYS (workspace) DOUBLE PRECISION array, dimension * (min(MMAX,NMAX)) * * WORK (workspace) DOUBLE PRECISION array, dimension (LNWK) * * LNWK (input) INTEGER * Workspace length. At least (MMAX*NMAX + 4*NMAX + MMAX). * * IWORK (workspace) INTEGER array, dimension (NMAX) * * NOUT (input) INTEGER * The unit number for output. * * ===================================================================== * * .. Parameters .. INTEGER NTYPES PARAMETER ( NTYPES = 3 ) INTEGER NTESTS PARAMETER ( NTESTS = 14 ) DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) * .. * .. Local Scalars .. CHARACTER*3 PATH INTEGER I, IM, IMODE, IN, INB, INFO, K, $ LDA, LW, LWORK, M, MNMIN, N, NB, NERRS, $ NFAIL, NRUN, NX, RANK DOUBLE PRECISION EPS, IRCOND, ORCOND * .. * .. Local Arrays .. INTEGER ISEED( 4 ), ISEEDY( 4 ) DOUBLE PRECISION RESULT( NTESTS ), SVLUES( 4 ) * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DQRT12, DRRT01, DRRT02 EXTERNAL DLAMCH, DQRT12, DRRT01, DRRT02 * .. * .. External Subroutines .. EXTERNAL ALAHD, ALASUM, DERRRR, DGEQPX, $ DGEQPY, DLACPY, $ DLAORD, DLASET, DLATMS * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Scalars in Common .. LOGICAL LERR, OK CHARACTER*6 SRNAMT INTEGER INFOT, IOUNIT * .. * .. Common blocks .. COMMON / INFOC / INFOT, IOUNIT, OK, LERR COMMON / SRNAMC / SRNAMT * .. * .. Data statements .. DATA ISEEDY / 1988, 1989, 1990, 1991 / * .. * .. Executable Statements .. * * Initialize constants and the random number seed. * PATH( 1: 1 ) = 'D' PATH( 2: 3 ) = 'RR' NRUN = 0 NFAIL = 0 NERRS = 0 DO 10 I = 1, 4 ISEED( I ) = ISEEDY( I ) 10 CONTINUE EPS = DLAMCH( 'Epsilon' ) IRCOND = EPS * * Test the error exits * IF( TSTERR ) $ CALL DERRRR( PATH, NOUT ) INFOT = 0 * DO 80 IM = 1, NM * * Do for each value of M in MVAL. * M = MVAL( IM ) LDA = MAX( 1, M ) * DO 70 IN = 1, NN * * Do for each value of N in NVAL. * N = NVAL( IN ) MNMIN = MIN( M, N ) LWORK = MAX( 1, M*MAX( M, N )+4*MNMIN+MAX( M, N ) ) * * Check if there is enough workspace. * IF( LWORK.GT.LNWK ) THEN WRITE(*,*) ' Error in DCHKRR.', 'Code 1:', $ ' Actual Workspace:', LNWK, $ ' Needed Workspace :', LWORK STOP ENDIF * DO 60 IMODE = 1, NTYPES IF( .NOT.DOTYPE( IMODE ) ) $ GO TO 60 * * Do for each type of matrix * 1: zero matrix * 2: one small singular value * 3: geometric distribution of singular values * * Generate test matrix of size m by n using * singular value distribution indicated by 'mode'. * IF( IMODE.EQ.1 ) THEN CALL DLASET( 'Full', M, N, ZERO, ZERO, $ COPYA, LDA ) DO 30 I = 1, MNMIN COPYS( I ) = ZERO 30 CONTINUE ELSE CALL DLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', $ COPYS, IMODE, ONE / EPS, ONE, M, N, $ 'No packing', COPYA, LDA, WORK, INFO ) CALL DLAORD( 'Decreasing', MNMIN, COPYS, 1 ) END IF * DO 90 INB = 1, NNB * * Do for each pair of values (NB,NX) in NBVAL and NXVAL. * NB = NBVAL( INB ) CALL XLAENV( 1, NB ) NX = NXVAL( INB ) CALL XLAENV( 3, NX ) * * * ****************** * * Testing xGEQPX * * ****************** * * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Test xGEQPX when JOB=1 * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Get a working copy of COPYA into A * CALL DLACPY( 'All', M, N, COPYA, LDA, A, LDA ) * IF( NB.LT.3 ) THEN LW = MAX( 1, 2*MNMIN+3*N ) ELSE LW = MAX( 1, 2*MNMIN+N*NB ) END IF * * Check if there is enough workspace for current * block size. * IF( LW.GT.LNWK ) THEN WRITE(*,*) ' Error in DCHKRR.', 'Code 2:', $ ' Workspace too short for blocksize',NB WRITE(*,*) ' Actual Workspace:', LNWK, $ ' Needed Workspace :', LW STOP ENDIF * * Compute the RRQR factorization of A * SRNAMT = 'DGEQPX' CALL DGEQPX( 1, M, N, 0, A, LDA, AQ, LDA, IWORK, $ IRCOND, ORCOND, RANK, SVLUES, WORK, LW, $ INFO ) * * Compute norm(svd(a) - svd(r)) * RESULT( 1 ) = DQRT12( M, N, A, LDA, COPYS, WORK, $ LWORK ) * * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Test xGEQPX when JOB=2 * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Get a work copy of matrix A from COPYA. * CALL DLACPY( 'All', M, N, COPYA, LDA, A, LDA ) * * Set WORK to identity. * CALL DLASET( 'All', M, M, ZERO, ONE, AQ, LDA ) * * Compute the Rank-Revealing QR factorization of A * IF ( NB.LT.3 ) THEN LW = MAX( 1, 2*MNMIN+2*N+MAX(N,M) ) ELSE LW = MAX( 1, 2*MNMIN+NB*NB+NB*MAX(N,M) ) END IF SRNAMT = 'DGEQPX' CALL DGEQPX( 2, M, N, M, A, LDA, AQ, LDA, IWORK, $ IRCOND, ORCOND, RANK, SVLUES, WORK, LW, $ INFO ) * * Compute norm(svd(a) - svd(r)) * RESULT( 2 ) = DQRT12( M, N, A, LDA, COPYS, $ WORK, LWORK ) * * Compute norm( A*P - Q*R ) * RESULT( 3 ) = DRRT01( 'Transpose', M, N, $ COPYA, LDA, IWORK, $ AQ, LDA, A, LDA, WORK, LWORK ) * * Compute norm( Q'*Q - Identity ) * RESULT( 4 ) = DRRT02( M, AQ, LDA, WORK, LWORK ) * * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Test xGEQPX when JOB=3 * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Get a work copy of matrix A from COPYA. * CALL DLACPY( 'All', M, N, COPYA, LDA, A, LDA ) * * Set WORK to identity. * CALL DLASET( 'All', M, M, ZERO, ONE, AQ, LDA ) * * Compute the Rank-Revealing QR factorization of A * IF ( NB.LT.3 ) THEN LW = MAX( 1, 2*MNMIN+2*N+MAX(N,M) ) ELSE LW = MAX( 1, 2*MNMIN+NB*NB+NB*MAX(N,M) ) END IF * SRNAMT = 'DGEQPX' CALL DGEQPX( 3, M, N, M, A, LDA, AQ, LDA, IWORK, $ IRCOND, ORCOND, RANK, SVLUES, WORK, LW, $ INFO ) * * Compute norm(svd(a) - svd(r)) * RESULT( 5 ) = DQRT12( M, N, A, LDA, COPYS, $ WORK, LWORK ) * * Compute norm( A*P - Q*R ) * RESULT( 6 ) = DRRT01( 'No transpose', M, N, $ COPYA, LDA, IWORK, $ AQ, LDA, A, LDA, WORK, LWORK ) * * Compute norm( Q'*Q - Identity ) * RESULT( 7 ) = DRRT02( M, AQ, LDA, WORK, LWORK ) * * * *-*-*-*-*-*-*-*-*-*-* * * Printing results * * *-*-*-*-*-*-*-*-*-*-* * * Print information about the tests that did not pass * the threshold. * DO 100 K = 1, 7 IF( RESULT( K ).GE.THRESH ) THEN IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) $ CALL ALAHD( NOUT, PATH ) WRITE( NOUT, FMT = 9999 ) 'DGEQPX', M, N, $ NB, IMODE, K, $ RESULT( K ) NFAIL = NFAIL + 1 END IF 100 CONTINUE NRUN = NRUN + 7 * * * ****************** * * Testing xGEQPY * * ****************** * * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Test xGEQPY when JOB=1 * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Get a working copy of COPYA into A * CALL DLACPY( 'All', M, N, COPYA, LDA, A, LDA ) * IF( NB.LT.3 ) THEN LW = MAX( 1, 2*MNMIN+3*N ) ELSE LW = MAX( 1, 2*MNMIN+N*NB ) END IF * * Check if there is enough workspace for current * block size. * IF( LW.GT.LNWK ) THEN WRITE(*,*) ' Error in DCHKRR.', 'Code 2:', $ ' Workspace too short for blocksize',NB WRITE(*,*) ' Actual Workspace:', LNWK, $ ' Needed Workspace :', LW STOP ENDIF * * Compute the RRQR factorization of A * SRNAMT = 'DGEQPY' CALL DGEQPY( 1, M, N, 0, A, LDA, AQ, LDA, IWORK, $ IRCOND, ORCOND, RANK, SVLUES, WORK, LW, $ INFO ) * * Compute norm(svd(a) - svd(r)) * RESULT( 8 ) = DQRT12( M, N, A, LDA, COPYS, WORK, $ LWORK ) * * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Test xGEQPY when JOB=2 * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Get a work copy of matrix A from COPYA. * CALL DLACPY( 'All', M, N, COPYA, LDA, A, LDA ) * * Set WORK to identity. * CALL DLASET( 'All', M, M, ZERO, ONE, AQ, LDA ) * * Compute the Rank-Revealing QR factorization of A * IF ( NB.LT.3 ) THEN LW = MAX( 1, 2*MNMIN+2*N+MAX(N,M) ) ELSE LW = MAX( 1, 2*MNMIN+NB*NB+NB*MAX(N,M) ) END IF SRNAMT = 'DGEQPY' CALL DGEQPY( 2, M, N, M, A, LDA, AQ, LDA, IWORK, $ IRCOND, ORCOND, RANK, SVLUES, WORK, LW, $ INFO ) * * Compute norm(svd(a) - svd(r)) * RESULT( 9 ) = DQRT12( M, N, A, LDA, COPYS, $ WORK, LWORK ) * * Compute norm( A*P - Q*R ) * RESULT( 10 ) = DRRT01( 'Transpose', M, N, $ COPYA, LDA, IWORK, $ AQ, LDA, A, LDA, WORK, LWORK ) * * Compute norm( Q'*Q - Identity ) * RESULT( 11 ) = DRRT02( M, AQ, LDA, WORK, LWORK ) * * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Test xGEQPY when JOB=3 * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Get a work copy of matrix A from COPYA. * CALL DLACPY( 'All', M, N, COPYA, LDA, A, LDA ) * * Set WORK to identity. * CALL DLASET( 'All', M, M, ZERO, ONE, AQ, LDA ) * * Compute the Rank-Revealing QR factorization of A * IF ( NB.LT.3 ) THEN LW = MAX( 1, 2*MNMIN+2*N+MAX(N,M) ) ELSE LW = MAX( 1, 2*MNMIN+NB*NB+NB*MAX(N,M) ) END IF * SRNAMT = 'DGEQPY' CALL DGEQPY( 3, M, N, M, A, LDA, AQ, LDA, IWORK, $ IRCOND, ORCOND, RANK, SVLUES, WORK, LW, $ INFO ) * * Compute norm(svd(a) - svd(r)) * RESULT( 12 ) = DQRT12( M, N, A, LDA, COPYS, $ WORK, LWORK ) * * Compute norm( A*P - Q*R ) * RESULT( 13 ) = DRRT01( 'No transpose', M, N, $ COPYA, LDA, IWORK, $ AQ, LDA, A, LDA, WORK, LWORK ) * * Compute norm( Q'*Q - Identity ) * RESULT( 14 ) = DRRT02( M, AQ, LDA, WORK, LWORK ) * * * *-*-*-*-*-*-*-*-*-*-* * * Printing results * * *-*-*-*-*-*-*-*-*-*-* * * Print information about the tests that did not pass * the threshold. * DO 110 K = 8, 14 IF( RESULT( K ).GE.THRESH ) THEN IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) $ CALL ALAHD( NOUT, PATH ) WRITE( NOUT, FMT = 9999 ) 'DGEQPY', M, N, $ NB, IMODE, K, $ RESULT( K ) NFAIL = NFAIL + 1 END IF 110 CONTINUE NRUN = NRUN + 7 * 90 CONTINUE 60 CONTINUE 70 CONTINUE 80 CONTINUE * * Print a summary of the results. * CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) * 9999 FORMAT( 1x, a6, ' M =', I5, ', N =', I5, ', NB =', I4, $ ', type ', I2, ', test ', I2, ', ratio =', G12.5 ) * * End if DCHKRR * END SHAR_EOF fi # end of overwriting check if test -f 'derrqp.f' then echo shar: will not over-write existing file "'derrqp.f'" else cat << SHAR_EOF > 'derrqp.f' SUBROUTINE DERRQP( PATH, NUNIT ) * * -- 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*3 PATH INTEGER NUNIT * .. * * Purpose * ======= * * DERRQP tests the error exits for DGEQPF. * * Arguments * ========= * * PATH (input) CHARACTER*3 * The LAPACK path name for the routines to be tested. * * NUNIT (input) INTEGER * The unit number for output. * * ===================================================================== * * .. Parameters .. INTEGER NMAX PARAMETER ( NMAX = 2 ) * .. * .. Local Scalars .. CHARACTER*2 C2 INTEGER INFO * .. * .. Local Arrays .. INTEGER IP( NMAX ) DOUBLE PRECISION A( NMAX, NMAX ), TAU( NMAX ), W( 3*NMAX ) * .. * .. External Functions .. LOGICAL LSAMEN EXTERNAL LSAMEN * .. * .. External Subroutines .. EXTERNAL ALAESM, CHKXER, DGEQPF * .. * .. Scalars in Common .. LOGICAL LERR, OK CHARACTER*6 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. COMMON / INFOC / INFOT, NOUT, OK, LERR COMMON / SRNAMC / SRNAMT * .. * .. Executable Statements .. * NOUT = NUNIT WRITE( NOUT, FMT = * ) C2 = PATH( 2: 3 ) A( 1, 1 ) = 1.D0 A( 1, 2 ) = 2.D0 A( 2, 2 ) = 3.D0 A( 2, 1 ) = 4.D0 OK = .TRUE. * IF( LSAMEN( 2, C2, 'QP' ) ) THEN * * Test error exits for QR factorization with pivoting * * DGEQPF * SRNAMT = 'DGEQPF' INFOT = 1 CALL DGEQPF( -1, 0, A, 1, IP, TAU, W, INFO ) CALL CHKXER( 'DGEQPF', INFOT, NOUT, LERR, OK ) INFOT = 2 CALL DGEQPF( 0, -1, A, 1, IP, TAU, W, INFO ) CALL CHKXER( 'DGEQPF', INFOT, NOUT, LERR, OK ) INFOT = 4 CALL DGEQPF( 2, 0, A, 1, IP, TAU, W, INFO ) CALL CHKXER( 'DGEQPF', INFOT, NOUT, LERR, OK ) END IF * * Print a summary line. * CALL ALAESM( PATH, OK, NOUT ) * RETURN * * End of DERRQP * END SHAR_EOF fi # end of overwriting check if test -f 'derrrr.f' then echo shar: will not over-write existing file "'derrrr.f'" else cat << SHAR_EOF > 'derrrr.f' SUBROUTINE DERRRR( PATH, NUNIT ) * * -- LAPACK test routine (version 1.0b) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * Rewritten for RRQR subroutines. * * .. Scalar Arguments .. CHARACTER*3 PATH INTEGER NUNIT * .. * * Purpose * ======= * * DERRRR tests the error exits for DGEQPX and DGEQPY. * * Arguments * ========= * * PATH (input) CHARACTER*3 * The LAPACK path name for the routines to be tested. * * NUNIT (input) INTEGER * The unit number for output. * * ===================================================================== * * .. Parameters .. INTEGER NMAX PARAMETER ( NMAX = 2 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. CHARACTER*2 C2 INTEGER INFO, RANK, LW DOUBLE PRECISION IRCOND, ORCOND * .. * .. Local Arrays .. INTEGER IP( NMAX ) DOUBLE PRECISION A( NMAX, NMAX ), C( NMAX, NMAX ), $ SVLUES( 4 ), W( 2*NMAX+3*NMAX ) * .. * .. External Functions .. LOGICAL LSAMEN EXTERNAL LSAMEN * .. * .. External Subroutines .. EXTERNAL ALAESM, CHKXER, DGEQPX, DGEQPY * .. * .. Scalars in Common .. LOGICAL LERR, OK CHARACTER*6 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. COMMON / INFOC / INFOT, NOUT, OK, LERR COMMON / SRNAMC / SRNAMT * .. * .. Executable Statements .. * IRCOND = ZERO RANK = 1 LW = 2*NMAX+3*NMAX NOUT = NUNIT WRITE( NOUT, FMT = * ) C2 = PATH( 2: 3 ) A( 1, 1 ) = 1.0D+0 A( 1, 2 ) = 2.0D+0 A( 2, 2 ) = 3.0D+0 A( 2, 1 ) = 4.0D+0 OK = .TRUE. * IF( LSAMEN( 2, C2, 'RR' ) ) THEN * * Test error exits for Rank-Revealing QR factorization * * DGEQPX * SRNAMT = 'DGEQPX' INFOT = 1 CALL DGEQPX( 4, 0, 0, 0, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, INFO ) CALL CHKXER( 'DGEQPX', INFOT, NOUT, LERR, OK ) INFOT = 2 CALL DGEQPX( 1, -1, 0, 0, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, INFO ) CALL CHKXER( 'DGEQPX', INFOT, NOUT, LERR, OK ) INFOT = 3 CALL DGEQPX( 1, 0, -1, 0, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, INFO ) CALL CHKXER( 'DGEQPX', INFOT, NOUT, LERR, OK ) INFOT = 4 CALL DGEQPX( 1, 0, 0, -1, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, INFO ) CALL CHKXER( 'DGEQPX', INFOT, NOUT, LERR, OK ) INFOT = 6 CALL DGEQPX( 1, 2, 0, 0, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, INFO ) CALL CHKXER( 'DGEQPX', INFOT, NOUT, LERR, OK ) INFOT = 8 CALL DGEQPX( 2, 2, 0, 0, A, 2, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, INFO ) CALL CHKXER( 'DGEQPX', INFOT, NOUT, LERR, OK ) INFOT = 10 CALL DGEQPX( 1, 0, 0, 0, A, 1, C, 1, IP, -ONE, ORCOND, $ RANK, SVLUES, W, LW, INFO ) CALL CHKXER( 'DGEQPX', INFOT, NOUT, LERR, OK ) INFOT = 15 CALL DGEQPX( 1, 0, 1, 0, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, 2, INFO ) CALL CHKXER( 'DGEQPX', INFOT, NOUT, LERR, OK ) * * DGEQPY * SRNAMT = 'DGEQPY' INFOT = 1 CALL DGEQPY( 4, 0, 0, 0, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, INFO ) CALL CHKXER( 'DGEQPY', INFOT, NOUT, LERR, OK ) INFOT = 2 CALL DGEQPY( 1, -1, 0, 0, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, INFO ) CALL CHKXER( 'DGEQPY', INFOT, NOUT, LERR, OK ) INFOT = 3 CALL DGEQPY( 1, 0, -1, 0, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, INFO ) CALL CHKXER( 'DGEQPY', INFOT, NOUT, LERR, OK ) INFOT = 4 CALL DGEQPY( 1, 0, 0, -1, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, INFO ) CALL CHKXER( 'DGEQPY', INFOT, NOUT, LERR, OK ) INFOT = 6 CALL DGEQPY( 1, 2, 0, 0, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, INFO ) CALL CHKXER( 'DGEQPY', INFOT, NOUT, LERR, OK ) INFOT = 8 CALL DGEQPY( 2, 2, 0, 0, A, 2, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, INFO ) CALL CHKXER( 'DGEQPY', INFOT, NOUT, LERR, OK ) INFOT = 10 CALL DGEQPY( 1, 0, 0, 0, A, 1, C, 1, IP, -ONE, ORCOND, $ RANK, SVLUES, W, LW, INFO ) CALL CHKXER( 'DGEQPY', INFOT, NOUT, LERR, OK ) INFOT = 15 CALL DGEQPY( 1, 0, 1, 0, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, 2, INFO ) CALL CHKXER( 'DGEQPY', INFOT, NOUT, LERR, OK ) END IF * * Print a summary line. * CALL ALAESM( PATH, OK, NOUT ) * RETURN * * End of DERRRR * END SHAR_EOF fi # end of overwriting check if test -f 'dlaord.f' then echo shar: will not over-write existing file "'dlaord.f'" else cat << SHAR_EOF > 'dlaord.f' SUBROUTINE DLAORD( JOB, N, X, INCX ) * * -- 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 * * .. Scalar Arguments .. CHARACTER JOB INTEGER INCX, N * .. * .. Array Arguments .. DOUBLE PRECISION X( * ) * .. * * Purpose * ======= * * DLAORD sorts the elements of a vector x in increasing or decreasing * order. * * Arguments * ========= * * JOB (input) CHARACTER * = 'I': Sort in increasing order * = 'D': Sort in decreasing order * * N (input) INTEGER * The length of the vector X. * * X (input/output) DOUBLE PRECISION array, dimension * (1+(N-1)*INCX) * On entry, the vector of length n to be sorted. * On exit, the vector x is sorted in the prescribed order. * * INCX (input) INTEGER * The spacing between successive elements of X. INCX >= 0. * * ===================================================================== * * .. Local Scalars .. INTEGER I, INC, IX, IXNEXT DOUBLE PRECISION TEMP * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. Executable Statements .. * INC = ABS( INCX ) IF( LSAME( JOB, 'I' ) ) THEN * * Sort in increasing order * DO 20 I = 2, N IX = 1 + ( I-1 )*INC 10 CONTINUE IF( IX.EQ.1 ) $ GO TO 20 IXNEXT = IX - INC IF( X( IX ).GT.X( IXNEXT ) ) THEN GO TO 20 ELSE TEMP = X( IX ) X( IX ) = X( IXNEXT ) X( IXNEXT ) = TEMP END IF IX = IXNEXT GO TO 10 20 CONTINUE * ELSE IF( LSAME( JOB, 'D' ) ) THEN * * Sort in decreasing order * DO 40 I = 2, N IX = 1 + ( I-1 )*INC 30 CONTINUE IF( IX.EQ.1 ) $ GO TO 40 IXNEXT = IX - INC IF( X( IX ).LT.X( IXNEXT ) ) THEN GO TO 40 ELSE TEMP = X( IX ) X( IX ) = X( IXNEXT ) X( IXNEXT ) = TEMP END IF IX = IXNEXT GO TO 30 40 CONTINUE END IF RETURN * * End of DLAORD * END SHAR_EOF fi # end of overwriting check if test -f 'dqpt01.f' then echo shar: will not over-write existing file "'dqpt01.f'" else cat << SHAR_EOF > 'dqpt01.f' DOUBLE PRECISION FUNCTION DQPT01( M, N, K, A, AF, LDA, TAU, JPVT, $ WORK, LWORK ) * * -- 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 .. INTEGER K, LDA, LWORK, M, N * .. * .. Array Arguments .. INTEGER JPVT( * ) DOUBLE PRECISION A( LDA, * ), AF( LDA, * ), TAU( * ), $ WORK( LWORK ) * .. * * Purpose * ======= * * DQPT01 tests the QR-factorization with pivoting of a matrix A. The * array AF contains the (possibly partial) QR-factorization of A, where * the upper triangle of AF(1:k,1:k) is a partial triangular factor, * the entries below the diagonal in the first k columns are the * Householder vectors, and the rest of AF contains a partially updated * matrix. * * This function returns ||A*P - Q*R||/(||norm(A)||*eps*M) * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrices A and AF. * * N (input) INTEGER * The number of columns of the matrices A and AF. * * K (input) INTEGER * The number of columns of AF that have been reduced * to upper triangular form. * * A (input) DOUBLE PRECISION array, dimension (LDA, N) * The original matrix A. * * AF (input) DOUBLE PRECISION array, dimension (LDA,N) * The (possibly partial) output of DGEQPF. The upper triangle * of AF(1:k,1:k) is a partial triangular factor, the entries * below the diagonal in the first k columns are the Householder * vectors, and the rest of AF contains a partially updated * matrix. * * LDA (input) INTEGER * The leading dimension of the arrays A and AF. * * TAU (input) DOUBLE PRECISION array, dimension (K) * Details of the Householder transformations as returned by * DGEQPF. * * JPVT (input) INTEGER array, dimension (N) * Pivot information as returned by DGEQPF. * * WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) * * LWORK (input) INTEGER * The length of the array WORK. LWORK >= M*N+N. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. INTEGER I, INFO, J DOUBLE PRECISION NORMA * .. * .. Local Arrays .. DOUBLE PRECISION RWORK( 1 ) * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DLAMCH, DLANGE * .. * .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DORMQR, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN * .. * .. Executable Statements .. * DQPT01 = ZERO * * Test if there is enough workspace * IF( LWORK.LT.M*N+N ) THEN CALL XERBLA( 'DQPT01', 10 ) RETURN END IF * * Quick return if possible * IF( M.LE.0 .OR. N.LE.0 ) $ RETURN * NORMA = DLANGE( 'One-norm', M, N, A, LDA, RWORK ) * DO 30 J = 1, K DO 10 I = 1, MIN( J, M ) WORK( ( J-1 )*M+I ) = AF( I, J ) 10 CONTINUE DO 20 I = J + 1, M WORK( ( J-1 )*M+I ) = ZERO 20 CONTINUE 30 CONTINUE DO 40 J = K + 1, N CALL DCOPY( M, AF( 1, J ), 1, WORK( ( J-1 )*M+1 ), 1 ) 40 CONTINUE * CALL DORMQR( 'Left', 'No transpose', M, N, K, AF, LDA, TAU, WORK, $ M, WORK( M*N+1 ), LWORK-M*N, INFO ) * DO 50 J = 1, N * * Compare i-th column of QR and jpvt(i)-th column of A * CALL DAXPY( M, -ONE, A( 1, JPVT( J ) ), 1, WORK( ( J-1 )*M+1 ), $ 1 ) 50 CONTINUE * DQPT01 = DLANGE( 'One-norm', M, N, WORK, M, RWORK ) / $ ( DBLE( MAX( M, N ) )*DLAMCH( 'Epsilon' ) ) IF( NORMA.NE.ZERO ) $ DQPT01 = DQPT01 / NORMA * RETURN * * End of DQPT01 * END SHAR_EOF fi # end of overwriting check if test -f 'dqrt11.f' then echo shar: will not over-write existing file "'dqrt11.f'" else cat << SHAR_EOF > 'dqrt11.f' DOUBLE PRECISION FUNCTION DQRT11( M, K, A, LDA, TAU, WORK, LWORK ) * * -- LAPACK 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 K, LDA, LWORK, M * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( LWORK ) * .. * * Purpose * ======= * * DQRT11 computes the test ratio * * || Q'*Q - I || / (eps * m) * * where the orthogonal matrix Q is represented as a product of * elementary transformations. Each transformation has the form * * H(k) = I - tau(k) v(k) v(k)' * * where tau(k) is stored in TAU(k) and v(k) is an m-vector of the form * [ 0 ... 0 1 x(k) ]', where x(k) is a vector of length m-k stored * in A(k+1:m,k). * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. * * K (input) INTEGER * The number of columns of A whose subdiagonal entries * contain information about orthogonal transformations. * * A (input) DOUBLE PRECISION array, dimension (LDA,K) * The (possibly partial) output of a QR reduction routine. * * LDA (input) INTEGER * The leading dimension of the array A. * * TAU (input) DOUBLE PRECISION array, dimension (K) * The scaling factors tau for the elementary transformations as * computed by the QR factorization routine. * * WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) * * LWORK (input) INTEGER * The length of the array WORK. LWORK >= M*M + M. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. INTEGER INFO, J * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DLAMCH, DLANGE * .. * .. External Subroutines .. EXTERNAL DLASET, DORM2R, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC DBLE * .. * .. Local Arrays .. DOUBLE PRECISION RDUMMY( 1 ) * .. * .. Executable Statements .. * DQRT11 = ZERO * * Test for sufficient workspace * IF( LWORK.LT.M*M+M ) THEN CALL XERBLA( 'DQRT11', 7 ) RETURN END IF * * Quick return if possible * IF( M.LE.0 ) $ RETURN * CALL DLASET( 'Full', M, M, ZERO, ONE, WORK, M ) * * Form Q * CALL DORM2R( 'Left', 'No transpose', M, M, K, A, LDA, TAU, WORK, $ M, WORK( M*M+1 ), INFO ) * * Form Q'*Q * CALL DORM2R( 'Left', 'Transpose', M, M, K, A, LDA, TAU, WORK, M, $ WORK( M*M+1 ), INFO ) * DO 10 J = 1, M WORK( ( J-1 )*M+J ) = WORK( ( J-1 )*M+J ) - ONE 10 CONTINUE * DQRT11 = DLANGE( 'One-norm', M, M, WORK, M, RDUMMY ) / $ ( DBLE( M )*DLAMCH( 'Epsilon' ) ) * RETURN * * End of DQRT11 * END SHAR_EOF fi # end of overwriting check if test -f 'dqrt12.f' then echo shar: will not over-write existing file "'dqrt12.f'" else cat << SHAR_EOF > 'dqrt12.f' DOUBLE PRECISION FUNCTION DQRT12( M, N, A, LDA, S, WORK, LWORK ) * * -- 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 .. INTEGER LDA, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), S( * ), WORK( LWORK ) * .. * * Purpose * ======= * * DQRT12 computes the singular values 'svlues' of the upper trapezoid * of A(1:M,1:N) and returns the ratio * * || s - svlues||/(||svlues||*eps*max(M,N)) * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. * * N (input) INTEGER * The number of columns of the matrix A. * * A (input) DOUBLE PRECISION array, dimension (LDA,N) * The M-by-N matrix A. Only the upper trapezoid is referenced. * * LDA (input) INTEGER * The leading dimension of the array A. * * S (input) DOUBLE PRECISION array, dimension (min(M,N)) * The singular values of the matrix A. * * WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) * * LWORK (input) INTEGER * The length of the array WORK. LWORK >= M*N + 4*min(M,N) + * max(M,N). * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. INTEGER I, INFO, ISCL, J, MN DOUBLE PRECISION ANRM, BIGNUM, NRMSVL, SMLNUM * .. * .. External Functions .. DOUBLE PRECISION DASUM, DLAMCH, DLANGE, DNRM2 EXTERNAL DASUM, DLAMCH, DLANGE, DNRM2 * .. * .. External Subroutines .. EXTERNAL DAXPY, DBDSQR, DGEBD2, DLABAD, DLASCL, DLASET, $ XERBLA * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN * .. * .. Local Arrays .. DOUBLE PRECISION DUMMY( 1 ) * .. * .. Executable Statements .. * DQRT12 = ZERO * * Test that enough workspace is supplied * IF( LWORK.LT.M*N+4*MIN( M, N )+MAX( M, N ) ) THEN CALL XERBLA( 'DQRT12', 7 ) RETURN END IF * * Quick return if possible * MN = MIN( M, N ) IF( MN.LE.ZERO ) $ RETURN * NRMSVL = DNRM2( MN, S, 1 ) * * Copy upper triangle of A into work * CALL DLASET( 'Full', M, N, ZERO, ZERO, WORK, M ) DO 20 J = 1, N DO 10 I = 1, MIN( J, M ) WORK( ( J-1 )*M+I ) = A( I, J ) 10 CONTINUE 20 CONTINUE * * Get machine parameters * SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) * * Scale work if max entry outside range [SMLNUM,BIGNUM] * ANRM = DLANGE( 'M', M, N, WORK, M, DUMMY ) ISCL = 0 IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN * * Scale matrix norm up to SMLNUM * CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, WORK, M, INFO ) ISCL = 1 ELSE IF( ANRM.GT.BIGNUM ) THEN * * Scale matrix norm down to BIGNUM * CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, WORK, M, INFO ) ISCL = 1 END IF * IF( ANRM.NE.ZERO ) THEN * * Compute SVD of work * CALL DGEBD2( M, N, WORK, M, WORK( M*N+1 ), WORK( M*N+MN+1 ), $ WORK( M*N+2*MN+1 ), WORK( M*N+3*MN+1 ), $ WORK( M*N+4*MN+1 ), INFO ) CALL DBDSQR( 'Upper', MN, 0, 0, 0, WORK( M*N+1 ), $ WORK( M*N+MN+1 ), DUMMY, MN, DUMMY, 1, DUMMY, MN, $ WORK( M*N+2*MN+1 ), INFO ) * IF( ISCL.EQ.1 ) THEN IF( ANRM.GT.BIGNUM ) THEN CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MN, 1, $ WORK( M*N+1 ), MN, INFO ) END IF IF( ANRM.LT.SMLNUM ) THEN CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MN, 1, $ WORK( M*N+1 ), MN, INFO ) END IF END IF * ELSE * DO 30 I = 1, MN WORK( M*N+I ) = ZERO 30 CONTINUE END IF * * Compare s and singular values of work * CALL DAXPY( MN, -ONE, S, 1, WORK( M*N+1 ), 1 ) DQRT12 = DASUM( MN, WORK( M*N+1 ), 1 ) / $ ( DLAMCH( 'Epsilon' )*DBLE( MAX( M, N ) ) ) IF( NRMSVL.NE.ZERO ) $ DQRT12 = DQRT12 / NRMSVL * RETURN * * End of DQRT12 * END SHAR_EOF fi # end of overwriting check if test -f 'drrt01.f' then echo shar: will not over-write existing file "'drrt01.f'" else cat << SHAR_EOF > 'drrt01.f' DOUBLE PRECISION FUNCTION DRRT01( TRANS, M, N, A, LDA, JPVT, $ Q, LDQ, R, LDR, WORK, LWORK ) * * * * .. Scalar Arguments .. CHARACTER*1 TRANS INTEGER M, N, LDA, LDQ, LDR, LWORK * .. * .. Array Arguments .. INTEGER JPVT( * ) DOUBLE PRECISION A( LDA, * ), Q( LDQ, * ), R( LDR, * ), $ WORK( LWORK ) * .. * * Purpose * ======= * * DRRT01 tests the Rank-Revealing QR-factorization of matrix A. * Array A contains the original matrix being factorized. * Argument TRANS says if array Q contains matrix Q or Q' (its * transpose). * Array R contains matrix R. * * This function returns ||A*P - Q*R||/(||norm(A)||*eps*M) * * Arguments * ========= * * TRANS (input) CHARACTER*1 * If TRANS='N', then array Q contains matrix Q. * If TRANS='T', then array Q contains the transpose of * matrix Q. * * M (input) INTEGER * Number of rows of matrices A, R and Q, * and number of columns of Q. * * N (input) INTEGER * Number of columns of matrices A and R. * * A (input) DOUBLE PRECISION array, dimension (LDA, N) * Original m by n matrix A. * * JPVT (input) INTEGER array, dimension (N) * Pivot information as returned by DGERQR. * * Q (input) DOUBLE PRECISION array, dimension (LDQ,M) * Array which contains m by m orthogonal matrix Q * or its tranpose, according argument TRANS. * * R (input) DOUBLE PRECISION array, dimension (LDR,N) * Upper triangular matrix. * The lower part of matrix R must contain zeroes. * * LDR (input) INTEGER * Leading dimension of arrays A and R. * * WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) * * LWORK (input) INTEGER * Length of array WORK. LWORK >= M*N. * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER LDWORK, J DOUBLE PRECISION NORMA * .. * .. Local Arrays .. DOUBLE PRECISION RDUMMY( 1 ) * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DLAMCH, DLANGE, LSAME * .. * .. External Subroutines .. EXTERNAL DCOPY, XERBLA, DGEMM * .. * .. Intrinsic Functions .. INTRINSIC MAX, DBLE * .. * .. Executable Statements .. * LDWORK = MAX( 1, M ) * * Test if there is enough workspace * IF( LWORK.LT.M*N ) THEN CALL XERBLA( 'DRRT01', 10 ) RETURN END IF * * Quick return if possible * IF( M.LE.0 .OR. N.LE.0 ) THEN DRRT01 = ZERO RETURN END IF * NORMA = DLANGE( 'One-norm', M, N, A, LDA, RDUMMY ) * * Compute WORK := A*P. * DO J = 1, N CALL DCOPY( M, A( 1, JPVT( J ) ), 1, $ WORK( (J-1)*M+1 ), 1 ) END DO * * Compute WORK := WORK - Q*R. * IF( LSAME( TRANS, 'N' ) ) THEN CALL DGEMM( 'No transpose', 'No transpose', M, N, M, -ONE, $ Q, LDQ, R, LDR, ONE, WORK, LDWORK ) ELSE CALL DGEMM( 'Transpose', 'No transpose', M, N, M, -ONE, $ Q, LDQ, R, LDR, ONE, WORK, LDWORK ) END IF * * Compute the 1-norm of WORK divided by (max(m,n)*eps). * DRRT01 = DLANGE( 'One-norm', M, N, WORK, LDWORK, $ RDUMMY ) / $ ( DBLE( MAX( M, N ) )*DLAMCH( 'Epsilon' ) ) IF( NORMA.NE.ZERO ) $ DRRT01 = DRRT01 / NORMA * RETURN * * End of DRRT01 * END SHAR_EOF fi # end of overwriting check if test -f 'drrt02.f' then echo shar: will not over-write existing file "'drrt02.f'" else cat << SHAR_EOF > 'drrt02.f' DOUBLE PRECISION FUNCTION DRRT02( M, QT, LDQT, WORK, LWORK ) * * * * .. Scalar Arguments .. INTEGER M, LDQT, LWORK * .. * .. Array Arguments .. DOUBLE PRECISION QT( LDQT, * ), WORK( LWORK ) * .. * * Purpose * ======= * * DRRT02 computes the test ratio * * || Q'*Q - I || / (eps * m) * * where the transpose of matrix Q (Q') is stored in array QT. * * * Arguments * ========= * * M (input) INTEGER * Number of rows and columns of matrix QT. * * QT (input) DOUBLE PRECISION array, dimension (LDQT,N) * Transpose of m by m matrix Q. * * LDQT (input) INTEGER * Leading dimension of array QT. * * WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) * * LWORK (input) INTEGER * The length of the array WORK. LWORK >= M*M. * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER LDWORK * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DLAMCH, DLANGE * .. * .. External Subroutines .. EXTERNAL DLASET, XERBLA, DGEMM * .. * .. Intrinsic Functions .. INTRINSIC MAX, DBLE * .. * .. Local Arrays .. DOUBLE PRECISION RDUMMY( 1 ) * .. * .. Executable Statements .. * LDWORK = MAX( 1, M ) * * Test for sufficient workspace * IF( LWORK.LT.M*M ) THEN CALL XERBLA( 'DRRT02', 7 ) RETURN END IF * * Quick return if possible * IF( M.LE.0 ) THEN DRRT02 = ZERO RETURN END IF * * Set WORK to the identity. * CALL DLASET( 'All',M, M, ZERO, ONE, WORK, LDWORK ) * * Compute WORK := WORK - QT * QT'. That is, WORK := WORK - Q'*Q. * CALL DGEMM( 'No transpose', 'Transpose', M, M, M, -ONE, $ QT, LDQT, QT, LDQT, ONE, WORK, LDWORK ) * * Compute || WORK || / ( m * eps ). * DRRT02 = DLANGE( 'One-norm', M, M, WORK, LDWORK, RDUMMY )/ $ ( DBLE( M )*DLAMCH( 'Epsilon' ) ) * RETURN * * End of DRRT02 * END SHAR_EOF fi # end of overwriting check if test -f 'ilaenv.f' then echo shar: will not over-write existing file "'ilaenv.f'" else cat << SHAR_EOF > 'ilaenv.f' INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, $ N4 ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. CHARACTER*( * ) NAME, OPTS INTEGER ISPEC, N1, N2, N3, N4 * .. * * Purpose * ======= * * ILAENV returns problem-dependent parameters for the local * environment. See ISPEC for a description of the parameters. * * In this version, the problem-dependent parameters are contained in * the integer array IPARMS in the common block CLAENV and the value * with index ISPEC is copied to ILAENV. This version of ILAENV is * to be used in conjunction with XLAENV in TESTING and TIMING. * * Arguments * ========= * * ISPEC (input) INTEGER * Specifies the parameter to be returned as the value of * ILAENV. * = 1: the optimal blocksize; if this value is 1, an unblocked * algorithm will give the best performance. * = 2: the minimum block size for which the block routine * should be used; if the usable block size is less than * this value, an unblocked routine should be used. * = 3: the crossover point (in a block routine, for N less * than this value, an unblocked routine should be used) * = 4: the number of shifts, used in the nonsymmetric * eigenvalue routines * = 5: the minimum column dimension for blocking to be used; * rectangular blocks must have dimension at least k by m, * where k is given by ILAENV(2,...) and m by ILAENV(5,...) * = 6: the crossover point for the SVD (when reducing an m by n * matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds * this value, a QR factorization is used first to reduce * the matrix to a triangular form.) * = 7: the number of processors * = 8: the crossover point for the multishift QR and QZ methods * for nonsymmetric eigenvalue problems. * * Other specifications (up to 100) can be added later. * * NAME (input) CHARACTER*(*) * The name of the calling subroutine. * * OPTS (input) CHARACTER*(*) * The character options to the subroutine NAME, concatenated * into a single character string. For example, UPLO = 'U', * TRANS = 'T', and DIAG = 'N' for a triangular routine would * be specified as OPTS = 'UTN'. * * N1 (input) INTEGER * N2 (input) INTEGER * N3 (input) INTEGER * N4 (input) INTEGER * Problem dimensions for the subroutine NAME; these may not all * be required. * * (ILAENV) (output) INTEGER * >= 0: the value of the parameter specified by ISPEC * < 0: if ILAENV = -k, the k-th argument had an illegal value. * * Further Details * =============== * * The following conventions have been used when calling ILAENV from the * LAPACK routines: * 1) OPTS is a concatenation of all of the character options to * subroutine NAME, in the same order that they appear in the * argument list for NAME, even if they are not used in determining * the value of the parameter specified by ISPEC. * 2) The problem dimensions N1, N2, N3, N4 are specified in the order * that they appear in the argument list for NAME. N1 is used * first, N2 second, and so on, and unused problem dimensions are * passed a value of -1. * 3) The parameter value returned by ILAENV is checked for validity in * the calling subroutine. For example, ILAENV is used to retrieve * the optimal blocksize for STRTRI as follows: * * NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) * IF( NB.LE.1 ) NB = MAX( 1, N ) * * ===================================================================== * * .. Intrinsic Functions .. INTRINSIC INT, MIN, REAL * .. * .. Arrays in Common .. INTEGER IPARMS( 100 ) * .. * .. Common blocks .. COMMON / CLAENV / IPARMS * .. * .. Save statement .. SAVE / CLAENV / * .. * .. Executable Statements .. * IF( ISPEC.GE.1 .AND. ISPEC.LE.5 ) THEN * * Return a value from the common block. * ILAENV = IPARMS( ISPEC ) * ELSE IF( ISPEC.EQ.6 ) THEN * * Compute SVD crossover point. * ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) * ELSE IF( ISPEC.GE.7 .AND. ISPEC.LE.8 ) THEN * * Return a value from the common block. * ILAENV = IPARMS( ISPEC ) * ELSE * * Invalid value for ISPEC * ILAENV = -1 END IF * RETURN * * End of ILAENV * END SHAR_EOF fi # end of overwriting check if test -f 'schkaa.f' then echo shar: will not over-write existing file "'schkaa.f'" else cat << SHAR_EOF > 'schkaa.f' PROGRAM SCHKAA * * -- 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 * * Purpose * ======= * * SCHKAA is the main test program for the REAL LAPACK * linear equation routines * * An annotated example of a data file can be obtained by deleting the * first 3 characters from the following lines: * Data file for testing REAL LAPACK linear eqn. routines * 7 Number of values of M * 0 1 2 3 5 10 16 Values of M (row dimension) * 7 Number of values of N * 0 1 2 3 5 10 16 Values of N (column dimension) * 5 Number of values of NB * 1 3 3 3 20 Values of NB (the blocksize) * 1 0 5 9 1 Values of NX (crossover point) * 20.0 Threshold value of test ratio * T Put T to test the LAPACK routines * T Put T to test the driver routines * T Put T to test the error exits * SQP 6 List types on next line if 0 < NTYPES < 6 * SRR 3 List types on next line if 0 < NTYPES < 3 * * Internal Parameters * =================== * * NMAX INTEGER * The maximum allowable value for N * * MAXIN INTEGER * The number of different values that can be used for each of * M, N, NB, and NX * * MAXRHS INTEGER * The maximum number of right hand sides * * NIN INTEGER * The unit number for input * * NOUT INTEGER * The unit number for output * * LWORK INTEGER * The workspace length * * ===================================================================== * * .. Parameters .. INTEGER NMAX PARAMETER ( NMAX = 501 ) INTEGER MAXIN PARAMETER ( MAXIN = 12 ) INTEGER MAXRHS PARAMETER ( MAXRHS = 10 ) INTEGER MATMAX PARAMETER ( MATMAX = 30 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER KDMAX PARAMETER ( KDMAX = NMAX+( NMAX+1 ) / 4 ) * INTEGER LWORK PARAMETER ( LWORK = NMAX*( NMAX+MAXRHS+5 ) ) * .. * .. Local Scalars .. LOGICAL FATAL, TSTCHK, TSTERR CHARACTER C1 CHARACTER*2 C2 CHARACTER*3 PATH CHARACTER*10 INTSTR CHARACTER*72 ALINE INTEGER I, IC, J, K, LDA, NB, NM, NMATS, NN, $ NNB, NNB2, NTYPES REAL EPS, S1, S2, THREQ, THRESH * .. * .. Local Arrays .. LOGICAL DOTYPE( MATMAX ) INTEGER IWORK( 3*NMAX ), MVAL( MAXIN ), NBVAL( MAXIN ), $ NBVAL2( MAXIN ), NVAL( MAXIN ), NXVAL( MAXIN ) REAL A( ( KDMAX+1 )*NMAX, 7 ), B( NMAX*MAXRHS, 4 ), $ WORK( NMAX, NMAX+MAXRHS+5 ) * .. * .. External Functions .. LOGICAL LSAME, LSAMEN REAL SLAMCH, SECOND EXTERNAL LSAME, LSAMEN, SLAMCH, SECOND * .. * .. External Subroutines .. EXTERNAL ALAREQ, SCHKQP, SCHKRR * .. * .. Scalars in Common .. LOGICAL LERR, OK CHARACTER*6 SRNAMT INTEGER INFOT, NUNIT * .. * .. Arrays in Common .. INTEGER IPARMS( 100 ) * .. * .. Common blocks .. COMMON / INFOC / INFOT, NUNIT, OK, LERR COMMON / SRNAMC / SRNAMT COMMON / CLAENV / IPARMS * .. * .. Data statements .. DATA THREQ / 2.0D0 / , INTSTR / '0123456789' / * .. * .. Executable Statements .. * S1 = SECOND( ) LDA = NMAX FATAL = .FALSE. * * Read a dummy line. * READ( NIN, FMT = * ) * * Report values of parameters. * WRITE( NOUT, FMT = 9994 ) * * Read the values of M * READ( NIN, FMT = * )NM IF( NM.LT.1 ) THEN WRITE( NOUT, FMT = 9996 )' NM ', NM, 1 NM = 0 FATAL = .TRUE. ELSE IF( NM.GT.MAXIN ) THEN WRITE( NOUT, FMT = 9995 )' NM ', NM, MAXIN NM = 0 FATAL = .TRUE. END IF READ( NIN, FMT = * )( MVAL( I ), I = 1, NM ) DO 10 I = 1, NM IF( MVAL( I ).LT.0 ) THEN WRITE( NOUT, FMT = 9996 )' M ', MVAL( I ), 0 FATAL = .TRUE. ELSE IF( MVAL( I ).GT.NMAX ) THEN WRITE( NOUT, FMT = 9995 )' M ', MVAL( I ), NMAX FATAL = .TRUE. END IF 10 CONTINUE IF( NM.GT.0 ) $ WRITE( NOUT, FMT = 9993 )'M ', ( MVAL( I ), I = 1, NM ) * * Read the values of N * READ( NIN, FMT = * )NN IF( NN.LT.1 ) THEN WRITE( NOUT, FMT = 9996 )' NN ', NN, 1 NN = 0 FATAL = .TRUE. ELSE IF( NN.GT.MAXIN ) THEN WRITE( NOUT, FMT = 9995 )' NN ', NN, MAXIN NN = 0 FATAL = .TRUE. END IF READ( NIN, FMT = * )( NVAL( I ), I = 1, NN ) DO 20 I = 1, NN IF( NVAL( I ).LT.0 ) THEN WRITE( NOUT, FMT = 9996 )' N ', NVAL( I ), 0 FATAL = .TRUE. ELSE IF( NVAL( I ).GT.NMAX ) THEN WRITE( NOUT, FMT = 9995 )' N ', NVAL( I ), NMAX FATAL = .TRUE. END IF 20 CONTINUE IF( NN.GT.0 ) $ WRITE( NOUT, FMT = 9993 )'N ', ( NVAL( I ), I = 1, NN ) * * Read the values of NB * READ( NIN, FMT = * )NNB IF( NNB.LT.1 ) THEN WRITE( NOUT, FMT = 9996 )'NNB ', NNB, 1 NNB = 0 FATAL = .TRUE. ELSE IF( NNB.GT.MAXIN ) THEN WRITE( NOUT, FMT = 9995 )'NNB ', NNB, MAXIN NNB = 0 FATAL = .TRUE. END IF READ( NIN, FMT = * )( NBVAL( I ), I = 1, NNB ) DO 40 I = 1, NNB IF( NBVAL( I ).LT.0 ) THEN WRITE( NOUT, FMT = 9996 )' NB ', NBVAL( I ), 0 FATAL = .TRUE. END IF 40 CONTINUE IF( NNB.GT.0 ) $ WRITE( NOUT, FMT = 9993 )'NB ', ( NBVAL( I ), I = 1, NNB ) * * Set NBVAL2 to be the set of unique values of NB * NNB2 = 0 DO 60 I = 1, NNB NB = NBVAL( I ) DO 50 J = 1, NNB2 IF( NB.EQ.NBVAL2( J ) ) $ GO TO 60 50 CONTINUE NNB2 = NNB2 + 1 NBVAL2( NNB2 ) = NB 60 CONTINUE * * Read the values of NX * READ( NIN, FMT = * )( NXVAL( I ), I = 1, NNB ) DO 70 I = 1, NNB IF( NXVAL( I ).LT.0 ) THEN WRITE( NOUT, FMT = 9996 )' NX ', NXVAL( I ), 0 FATAL = .TRUE. END IF 70 CONTINUE IF( NNB.GT.0 ) $ WRITE( NOUT, FMT = 9993 )'NX ', ( NXVAL( I ), I = 1, NNB ) * * Read the threshold value for the test ratios. * READ( NIN, FMT = * )THRESH WRITE( NOUT, FMT = 9992 )THRESH * * Read the flag that indicates whether to test the LAPACK routines. * READ( NIN, FMT = * )TSTCHK * * Read the flag that indicates whether to test the error exits. * READ( NIN, FMT = * )TSTERR * IF( FATAL ) THEN WRITE( NOUT, FMT = 9999 ) STOP END IF * * Calculate and print the machine dependent constants. * EPS = SLAMCH( 'Underflow threshold' ) WRITE( NOUT, FMT = 9991 )'underflow', EPS EPS = SLAMCH( 'Overflow threshold' ) WRITE( NOUT, FMT = 9991 )'overflow ', EPS EPS = SLAMCH( 'Epsilon' ) WRITE( NOUT, FMT = 9991 )'precision', EPS WRITE( NOUT, FMT = * ) * 80 CONTINUE * * Read a test path and the number of matrix types to use. * READ( NIN, FMT = '(A72)', END = 140 )ALINE PATH = ALINE( 1: 3 ) NMATS = MATMAX I = 3 90 CONTINUE I = I + 1 IF( I.GT.72 ) THEN NMATS = MATMAX GO TO 130 END IF IF( ALINE( I: I ).EQ.' ' ) $ GO TO 90 NMATS = 0 100 CONTINUE C1 = ALINE( I: I ) DO 110 K = 1, 10 IF( C1.EQ.INTSTR( K: K ) ) THEN IC = K - 1 GO TO 120 END IF 110 CONTINUE GO TO 130 120 CONTINUE NMATS = NMATS*10 + IC I = I + 1 IF( I.GT.72 ) $ GO TO 130 GO TO 100 130 CONTINUE C1 = PATH( 1: 1 ) C2 = PATH( 2: 3 ) * * Check first character for correct precision. * IF( .NOT.LSAME( C1, 'S precision' ) ) THEN WRITE( NOUT, FMT = 9990 )PATH * ELSE IF( NMATS.LE.0 ) THEN * * Check for a positive number of tests requested. * WRITE( NOUT, FMT = 9989 )PATH * ELSE IF( LSAMEN( 2, C2, 'QP' ) ) THEN * * QP: QR factorization with pivoting * NTYPES = 6 CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) * IF( TSTCHK ) THEN CALL SCHKQP( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, $ A( 1, 1 ), A( 1, 2 ), B( 1, 1 ), B( 1, 2 ), $ B( 1, 3 ), WORK, IWORK, NOUT ) ELSE WRITE( NOUT, FMT = 9989 )PATH END IF * ELSE IF( LSAMEN( 2, C2, 'RR' ) ) THEN * * RR: Rank-Revealing QR factorization * NTYPES = 3 CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) * IF( TSTCHK ) THEN CALL SCHKRR( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, $ NXVAL, THRESH, TSTERR, A( 1, 1 ), A( 1, 2 ), $ A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), $ WORK, LWORK, IWORK, NOUT ) ELSE WRITE( NOUT, FMT = 9989 )PATH END IF * ELSE * WRITE( NOUT, FMT = 9990 )PATH END IF * * Go back to get another input line. * GO TO 80 * * Branch to this line when the last record is read. * 140 CONTINUE CLOSE ( NIN ) S2 = SECOND( ) WRITE( NOUT, FMT = 9998 ) WRITE( NOUT, FMT = 9997 )S2 - S1 * 9999 FORMAT( / ' Execution not attempted due to input errors' ) 9998 FORMAT( / ' End of tests' ) 9997 FORMAT( ' Total time used = ', F12.2, ' seconds', / ) 9996 FORMAT( ' Invalid input value: ', A4, '=', I6, '; must be >=', $ I6 ) 9995 FORMAT( ' Invalid input value: ', A4, '=', I6, '; must be <=', $ I6 ) 9994 FORMAT( ' RRQR Tests. REAL routines ', $ / / ' The following parameter values will be used:' ) 9993 FORMAT( 4X, A4, ': ', 10I6, / 11X, 10I6 ) 9992 FORMAT( / ' Routines pass computational tests if test ratio is ', $ 'less than', F8.2, / ) 9991 FORMAT( ' Relative machine ', A, ' is taken to be', D16.6 ) 9990 FORMAT( / 1X, A3, ': Unrecognized path name' ) 9989 FORMAT( / 1X, A3, ' routines were not tested' ) 9988 FORMAT( / 1X, A3, ' driver routines were not tested' ) * * End of SCHKAA * END SHAR_EOF fi # end of overwriting check if test -f 'schkqp.f' then echo shar: will not over-write existing file "'schkqp.f'" else cat << SHAR_EOF > 'schkqp.f' SUBROUTINE SCHKQP( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A, $ COPYA, S, COPYS, TAU, WORK, IWORK, NOUT ) * * -- 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 .. LOGICAL TSTERR INTEGER NM, NN, NOUT REAL THRESH * .. * .. Array Arguments .. LOGICAL DOTYPE( * ) INTEGER IWORK( * ), MVAL( * ), NVAL( * ) REAL A( * ), COPYA( * ), COPYS( * ), S( * ), $ TAU( * ), WORK( * ) * .. * * Purpose * ======= * * SCHKQP tests SGEQPF. * * Arguments * ========= * * DOTYPE (input) LOGICAL array, dimension (NTYPES) * The matrix types to be used for testing. Matrices of type j * (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = * .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. * * NM (input) INTEGER * The number of values of M contained in the vector MVAL. * * MVAL (input) INTEGER array, dimension (NM) * The values of the matrix row dimension M. * * NN (input) INTEGER * The number of values of N contained in the vector NVAL. * * NVAL (input) INTEGER array, dimension (NN) * The values of the matrix column dimension N. * * THRESH (input) REAL * The threshold value for the test ratios. A result is * included in the output file if RESULT >= THRESH. To have * every test ratio printed, use THRESH = 0. * * TSTERR (input) LOGICAL * Flag that indicates whether error exits are to be tested. * * A (workspace) REAL array, dimension (MMAX*NMAX) * where MMAX is the maximum value of M in MVAL and NMAX is the * maximum value of N in NVAL. * * COPYA (workspace) REAL array, dimension (MMAX*NMAX) * * S (workspace) REAL array, dimension * (min(MMAX,NMAX)) * * COPYS (workspace) REAL array, dimension * (min(MMAX,NMAX)) * * TAU (workspace) REAL array, dimension (MMAX) * * WORK (workspace) REAL array, dimension * (MMAX*NMAX + 4*NMAX + MMAX) * * IWORK (workspace) INTEGER array, dimension (NMAX) * * NOUT (input) INTEGER * The unit number for output. * * ===================================================================== * * .. Parameters .. INTEGER NTYPES PARAMETER ( NTYPES = 6 ) INTEGER NTESTS PARAMETER ( NTESTS = 3 ) REAL ONE, ZERO PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 ) * .. * .. Local Scalars .. CHARACTER*3 PATH INTEGER I, IHIGH, ILOW, IM, IMODE, IN, INFO, ISTEP, K, $ LDA, LWORK, M, MNMIN, MODE, N, NERRS, NFAIL, $ NRUN REAL EPS * .. * .. Local Arrays .. INTEGER ISEED( 4 ), ISEEDY( 4 ) REAL RESULT( NTESTS ) * .. * .. External Functions .. REAL SLAMCH, SQPT01, SQRT11, SQRT12 EXTERNAL SLAMCH, SQPT01, SQRT11, SQRT12 * .. * .. External Subroutines .. EXTERNAL ALAHD, ALASUM, SERRQP, SGEQPF, SLACPY, SLAORD, $ SLASET, SLATMS * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Scalars in Common .. LOGICAL LERR, OK CHARACTER*6 SRNAMT INTEGER INFOT, IOUNIT * .. * .. Common blocks .. COMMON / INFOC / INFOT, IOUNIT, OK, LERR COMMON / SRNAMC / SRNAMT * .. * .. Data statements .. DATA ISEEDY / 1988, 1989, 1990, 1991 / * .. * .. Executable Statements .. * * Initialize constants and the random number seed. * PATH( 1: 1 ) = 'S' PATH( 2: 3 ) = 'QP' NRUN = 0 NFAIL = 0 NERRS = 0 DO 10 I = 1, 4 ISEED( I ) = ISEEDY( I ) 10 CONTINUE EPS = SLAMCH( 'Epsilon' ) * * Test the error exits * IF( TSTERR ) $ CALL SERRQP( PATH, NOUT ) INFOT = 0 * DO 80 IM = 1, NM * * Do for each value of M in MVAL. * M = MVAL( IM ) LDA = MAX( 1, M ) * DO 70 IN = 1, NN * * Do for each value of N in NVAL. * N = NVAL( IN ) MNMIN = MIN( M, N ) LWORK = MAX( 1, M*MAX( M, N ) + 4*MNMIN + MAX( M, N ) ) * DO 60 IMODE = 1, NTYPES IF( .NOT.DOTYPE( IMODE ) ) $ GO TO 60 * * Do for each type of matrix * 1: zero matrix * 2: one small singular value * 3: geometric distribution of singular values * 4: first n/2 columns fixed * 5: last n/2 columns fixed * 6: every second column fixed * MODE = IMODE IF( IMODE.GT.3 ) $ MODE = 1 * * Generate test matrix of size m by n using * singular value distribution indicated by 'mode'. * DO 20 I = 1, N IWORK( I ) = 0 20 CONTINUE IF( IMODE.EQ.1 ) THEN CALL SLASET( 'Full', M, N, ZERO, ZERO, COPYA, LDA ) DO 30 I = 1, MNMIN COPYS( I ) = ZERO 30 CONTINUE ELSE CALL SLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', COPYS, $ MODE, ONE / EPS, ONE, M, N, 'No packing', $ COPYA, LDA, WORK, INFO ) IF( IMODE.GE.4 ) THEN IF( IMODE.EQ.4 ) THEN ILOW = 1 ISTEP = 1 IHIGH = MAX( 1, N / 2 ) ELSE IF( IMODE.EQ.5 ) THEN ILOW = MAX( 1, N / 2 ) ISTEP = 1 IHIGH = N ELSE IF( IMODE.EQ.6 ) THEN ILOW = 1 ISTEP = 2 IHIGH = N END IF DO 40 I = ILOW, IHIGH, ISTEP IWORK( I ) = 1 40 CONTINUE END IF CALL SLAORD( 'Decreasing', MNMIN, COPYS, 1 ) END IF * * Save A and its singular values * CALL SLACPY( 'All', M, N, COPYA, LDA, A, LDA ) * * Compute the QR factorization with pivoting of A * SRNAMT = 'SGEQPF' CALL SGEQPF( M, N, A, LDA, IWORK, TAU, WORK, INFO ) * * Compute norm(svd(a) - svd(r)) * RESULT( 1 ) = SQRT12( M, N, A, LDA, COPYS, WORK, LWORK ) * * Compute norm( A*P - Q*R ) * RESULT( 2 ) = SQPT01( M, N, MNMIN, COPYA, A, LDA, TAU, $ IWORK, WORK, LWORK ) * * Compute Q'*Q * RESULT( 3 ) = SQRT11( M, MNMIN, A, LDA, TAU, WORK, $ LWORK ) * * Print information about the tests that did not pass * the threshold. * DO 50 K = 1, 3 IF( RESULT( K ).GE.THRESH ) THEN IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) $ CALL ALAHD( NOUT, PATH ) WRITE( NOUT, FMT = 9999 )M, N, IMODE, K, $ RESULT( K ) NFAIL = NFAIL + 1 END IF 50 CONTINUE NRUN = NRUN + 3 60 CONTINUE 70 CONTINUE 80 CONTINUE * * Print a summary of the results. * CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) * 9999 FORMAT( ' M =', I5, ', N =', I5, ', type ', I2, ', test ', I2, $ ', ratio =', G12.5 ) * * End if SCHKQP * END SHAR_EOF fi # end of overwriting check if test -f 'schkrr.f' then echo shar: will not over-write existing file "'schkrr.f'" else cat << SHAR_EOF > 'schkrr.f' SUBROUTINE SCHKRR( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, $ NXVAL, THRESH, TSTERR, A, AQ, COPYA, S, COPYS, $ WORK, LNWK, IWORK, NOUT ) * * -- 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 * * Rewritten to test the new RRQR Subroutines. * * * .. Scalar Arguments .. LOGICAL TSTERR INTEGER LNWK, NM, NN, NNB, NOUT REAL THRESH * .. * .. Array Arguments .. LOGICAL DOTYPE( * ) INTEGER IWORK( * ), MVAL( * ), NVAL( * ), $ NBVAL( * ), NXVAL( * ) REAL A( * ), AQ( * ), COPYA( * ), $ COPYS( * ), S( * ), WORK( LNWK ) * .. * * Purpose * ======= * * SCHKRR tests SGEQPX and SGEQPY. * * Arguments * ========= * * DOTYPE (input) LOGICAL array, dimension (NTYPES) * The matrix types to be used for testing. Matrices of type j * (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = * .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. * * NM (input) INTEGER * The number of values of M contained in the vector MVAL. * * MVAL (input) INTEGER array, dimension (NM) * The values of the matrix row dimension M. * * NN (input) INTEGER * The number of values of N contained in the vector NVAL. * * NVAL (input) INTEGER array, dimension (NN) * The values of the matrix column dimension N. * * NNB (input) INTEGER * The number of values of NB and NX contained in the * vectors NBVAL and NXVAL. The blocking parameters are used * in pairs (NB,NX). * * NBVAL (input) INTEGER array, dimension (NNB) * The values of the blocksize NB. * * NXVAL (input) INTEGER array, dimension (NNB) * The values of the crossover point NX. * * THRESH (input) REAL * The threshold value for the test ratios. A result is * included in the output file if RESULT >= THRESH. To have * every test ratio printed, use THRESH = 0. * * TSTERR (input) LOGICAL * Flag that indicates whether error exits are to be tested. * * A (workspace) REAL array, dimension (MMAX*NMAX) * where MMAX is the maximum value of M in MVAL and NMAX is the * maximum value of N in NVAL. * * AQ (workspace) REAL array, dimension (MMAX*NMAX) * where MMAX is the maximum value of M in MVAL and NMAX is the * maximum value of N in NVAL. * * COPYA (workspace) REAL array, dimension (MMAX*NMAX) * * S (workspace) REAL array, dimension * (min(MMAX,NMAX)) * * COPYS (workspace) REAL array, dimension * (min(MMAX,NMAX)) * * WORK (workspace) REAL array, dimension (LNWK) * * LNWK (input) INTEGER * Workspace length. At least (MMAX*NMAX + 4*NMAX + MMAX). * * IWORK (workspace) INTEGER array, dimension (NMAX) * * NOUT (input) INTEGER * The unit number for output. * * ===================================================================== * * .. Parameters .. INTEGER NTYPES PARAMETER ( NTYPES = 3 ) INTEGER NTESTS PARAMETER ( NTESTS = 14 ) REAL ONE, ZERO PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 ) * .. * .. Local Scalars .. CHARACTER*3 PATH INTEGER I, IM, IMODE, IN, INB, INFO, K, $ LDA, LW, LWORK, M, MNMIN, N, NB, NERRS, $ NFAIL, NRUN, NX, RANK REAL EPS, IRCOND, ORCOND * .. * .. Local Arrays .. INTEGER ISEED( 4 ), ISEEDY( 4 ) REAL RESULT( NTESTS ), SVLUES( 4 ) * .. * .. External Functions .. REAL SLAMCH, SQRT12, SRRT01, SRRT02 EXTERNAL SLAMCH, SQRT12, SRRT01, SRRT02 * .. * .. External Subroutines .. EXTERNAL ALAHD, ALASUM, SERRRR, SGEQPX, $ SGEQPY, SLACPY, $ SLAORD, SLASET, SLATMS * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Scalars in Common .. LOGICAL LERR, OK CHARACTER*6 SRNAMT INTEGER INFOT, IOUNIT * .. * .. Common blocks .. COMMON / INFOC / INFOT, IOUNIT, OK, LERR COMMON / SRNAMC / SRNAMT * .. * .. Data statements .. DATA ISEEDY / 1988, 1989, 1990, 1991 / * .. * .. Executable Statements .. * * Initialize constants and the random number seed. * PATH( 1: 1 ) = 'S' PATH( 2: 3 ) = 'RR' NRUN = 0 NFAIL = 0 NERRS = 0 DO 10 I = 1, 4 ISEED( I ) = ISEEDY( I ) 10 CONTINUE EPS = SLAMCH( 'Epsilon' ) IRCOND = EPS * * Test the error exits * IF( TSTERR ) $ CALL SERRRR( PATH, NOUT ) INFOT = 0 * DO 80 IM = 1, NM * * Do for each value of M in MVAL. * M = MVAL( IM ) LDA = MAX( 1, M ) * DO 70 IN = 1, NN * * Do for each value of N in NVAL. * N = NVAL( IN ) MNMIN = MIN( M, N ) LWORK = MAX( 1, M*MAX( M, N )+4*MNMIN+MAX( M, N ) ) * * Check if there is enough workspace. * IF( LWORK.GT.LNWK ) THEN WRITE(*,*) ' Error in SCHKRR.', 'Code 1:', $ ' Actual Workspace:', LNWK, $ ' Needed Workspace :', LWORK STOP ENDIF * DO 60 IMODE = 1, NTYPES IF( .NOT.DOTYPE( IMODE ) ) $ GO TO 60 * * Do for each type of matrix * 1: zero matrix * 2: one small singular value * 3: geometric distribution of singular values * * Generate test matrix of size m by n using * singular value distribution indicated by 'mode'. * IF( IMODE.EQ.1 ) THEN CALL SLASET( 'Full', M, N, ZERO, ZERO, $ COPYA, LDA ) DO 30 I = 1, MNMIN COPYS( I ) = ZERO 30 CONTINUE ELSE CALL SLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', $ COPYS, IMODE, ONE / EPS, ONE, M, N, $ 'No packing', COPYA, LDA, WORK, INFO ) CALL SLAORD( 'Decreasing', MNMIN, COPYS, 1 ) END IF * DO 90 INB = 1, NNB * * Do for each pair of values (NB,NX) in NBVAL and NXVAL. * NB = NBVAL( INB ) CALL XLAENV( 1, NB ) NX = NXVAL( INB ) CALL XLAENV( 3, NX ) * * * ****************** * * Testing xGEQPX * * ****************** * * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Test xGEQPX when JOB=1 * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Get a working copy of COPYA into A * CALL SLACPY( 'All', M, N, COPYA, LDA, A, LDA ) * IF( NB.LT.3 ) THEN LW = MAX( 1, 2*MNMIN+3*N ) ELSE LW = MAX( 1, 2*MNMIN+N*NB ) END IF * * Check if there is enough workspace for current * block size. * IF( LW.GT.LNWK ) THEN WRITE(*,*) ' Error in SCHKRR.', 'Code 2:', $ ' Workspace too short for blocksize',NB WRITE(*,*) ' Actual Workspace:', LNWK, $ ' Needed Workspace :', LW STOP ENDIF * * Compute the RRQR factorization of A * SRNAMT = 'SGEQPX' CALL SGEQPX( 1, M, N, 0, A, LDA, AQ, LDA, IWORK, $ IRCOND, ORCOND, RANK, SVLUES, WORK, LW, $ INFO ) * * Compute norm(svd(a) - svd(r)) * RESULT( 1 ) = SQRT12( M, N, A, LDA, COPYS, WORK, $ LWORK ) * * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Test xGEQPX when JOB=2 * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Get a work copy of matrix A from COPYA. * CALL SLACPY( 'All', M, N, COPYA, LDA, A, LDA ) * * Set WORK to identity. * CALL SLASET( 'All', M, M, ZERO, ONE, AQ, LDA ) * * Compute the Rank-Revealing QR factorization of A * IF ( NB.LT.3 ) THEN LW = MAX( 1, 2*MNMIN+2*N+MAX(N,M) ) ELSE LW = MAX( 1, 2*MNMIN+NB*NB+NB*MAX(N,M) ) END IF SRNAMT = 'SGEQPX' CALL SGEQPX( 2, M, N, M, A, LDA, AQ, LDA, IWORK, $ IRCOND, ORCOND, RANK, SVLUES, WORK, LW, $ INFO ) * * Compute norm(svd(a) - svd(r)) * RESULT( 2 ) = SQRT12( M, N, A, LDA, COPYS, $ WORK, LWORK ) * * Compute norm( A*P - Q*R ) * RESULT( 3 ) = SRRT01( 'Transpose', M, N, $ COPYA, LDA, IWORK, $ AQ, LDA, A, LDA, WORK, LWORK ) * * Compute norm( Q'*Q - Identity ) * RESULT( 4 ) = SRRT02( M, AQ, LDA, WORK, LWORK ) * * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Test xGEQPX when JOB=3 * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Get a work copy of matrix A from COPYA. * CALL SLACPY( 'All', M, N, COPYA, LDA, A, LDA ) * * Set WORK to identity. * CALL SLASET( 'All', M, M, ZERO, ONE, AQ, LDA ) * * Compute the Rank-Revealing QR factorization of A * IF ( NB.LT.3 ) THEN LW = MAX( 1, 2*MNMIN+2*N+MAX(N,M) ) ELSE LW = MAX( 1, 2*MNMIN+NB*NB+NB*MAX(N,M) ) END IF * SRNAMT = 'SGEQPX' CALL SGEQPX( 3, M, N, M, A, LDA, AQ, LDA, IWORK, $ IRCOND, ORCOND, RANK, SVLUES, WORK, LW, $ INFO ) * * Compute norm(svd(a) - svd(r)) * RESULT( 5 ) = SQRT12( M, N, A, LDA, COPYS, $ WORK, LWORK ) * * Compute norm( A*P - Q*R ) * RESULT( 6 ) = SRRT01( 'No transpose', M, N, $ COPYA, LDA, IWORK, $ AQ, LDA, A, LDA, WORK, LWORK ) * * Compute norm( Q'*Q - Identity ) * RESULT( 7 ) = SRRT02( M, AQ, LDA, WORK, LWORK ) * * * *-*-*-*-*-*-*-*-*-*-* * * Printing results * * *-*-*-*-*-*-*-*-*-*-* * * Print information about the tests that did not pass * the threshold. * DO 100 K = 1, 7 IF( RESULT( K ).GE.THRESH ) THEN IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) $ CALL ALAHD( NOUT, PATH ) WRITE( NOUT, FMT = 9999 ) 'SGEQPX', M, N, $ NB, IMODE, K, $ RESULT( K ) NFAIL = NFAIL + 1 END IF 100 CONTINUE NRUN = NRUN + 7 * * * ****************** * * Testing xGEQPY * * ****************** * * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Test xGEQPY when JOB=1 * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Get a working copy of COPYA into A * CALL SLACPY( 'All', M, N, COPYA, LDA, A, LDA ) * IF( NB.LT.3 ) THEN LW = MAX( 1, 2*MNMIN+3*N ) ELSE LW = MAX( 1, 2*MNMIN+N*NB ) END IF * * Check if there is enough workspace for current * block size. * IF( LW.GT.LNWK ) THEN WRITE(*,*) ' Error in SCHKRR.', 'Code 2:', $ ' Workspace too short for blocksize',NB WRITE(*,*) ' Actual Workspace:', LNWK, $ ' Needed Workspace :', LW STOP ENDIF * * Compute the RRQR factorization of A * SRNAMT = 'SGEQPY' CALL SGEQPY( 1, M, N, 0, A, LDA, AQ, LDA, IWORK, $ IRCOND, ORCOND, RANK, SVLUES, WORK, LW, $ INFO ) * * Compute norm(svd(a) - svd(r)) * RESULT( 8 ) = SQRT12( M, N, A, LDA, COPYS, WORK, $ LWORK ) * * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Test xGEQPY when JOB=2 * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Get a work copy of matrix A from COPYA. * CALL SLACPY( 'All', M, N, COPYA, LDA, A, LDA ) * * Set WORK to identity. * CALL SLASET( 'All', M, M, ZERO, ONE, AQ, LDA ) * * Compute the Rank-Revealing QR factorization of A * IF ( NB.LT.3 ) THEN LW = MAX( 1, 2*MNMIN+2*N+MAX(N,M) ) ELSE LW = MAX( 1, 2*MNMIN+NB*NB+NB*MAX(N,M) ) END IF SRNAMT = 'SGEQPY' CALL SGEQPY( 2, M, N, M, A, LDA, AQ, LDA, IWORK, $ IRCOND, ORCOND, RANK, SVLUES, WORK, LW, $ INFO ) * * Compute norm(svd(a) - svd(r)) * RESULT( 9 ) = SQRT12( M, N, A, LDA, COPYS, $ WORK, LWORK ) * * Compute norm( A*P - Q*R ) * RESULT( 10 ) = SRRT01( 'Transpose', M, N, $ COPYA, LDA, IWORK, $ AQ, LDA, A, LDA, WORK, LWORK ) * * Compute norm( Q'*Q - Identity ) * RESULT( 11 ) = SRRT02( M, AQ, LDA, WORK, LWORK ) * * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Test xGEQPY when JOB=3 * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Get a work copy of matrix A from COPYA. * CALL SLACPY( 'All', M, N, COPYA, LDA, A, LDA ) * * Set WORK to identity. * CALL SLASET( 'All', M, M, ZERO, ONE, AQ, LDA ) * * Compute the Rank-Revealing QR factorization of A * IF ( NB.LT.3 ) THEN LW = MAX( 1, 2*MNMIN+2*N+MAX(N,M) ) ELSE LW = MAX( 1, 2*MNMIN+NB*NB+NB*MAX(N,M) ) END IF * SRNAMT = 'SGEQPY' CALL SGEQPY( 3, M, N, M, A, LDA, AQ, LDA, IWORK, $ IRCOND, ORCOND, RANK, SVLUES, WORK, LW, $ INFO ) * * Compute norm(svd(a) - svd(r)) * RESULT( 12 ) = SQRT12( M, N, A, LDA, COPYS, $ WORK, LWORK ) * * Compute norm( A*P - Q*R ) * RESULT( 13 ) = SRRT01( 'No transpose', M, N, $ COPYA, LDA, IWORK, $ AQ, LDA, A, LDA, WORK, LWORK ) * * Compute norm( Q'*Q - Identity ) * RESULT( 14 ) = SRRT02( M, AQ, LDA, WORK, LWORK ) * * * *-*-*-*-*-*-*-*-*-*-* * * Printing results * * *-*-*-*-*-*-*-*-*-*-* * * Print information about the tests that did not pass * the threshold. * DO 110 K = 8, 14 IF( RESULT( K ).GE.THRESH ) THEN IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) $ CALL ALAHD( NOUT, PATH ) WRITE( NOUT, FMT = 9999 ) 'SGEQPY', M, N, $ NB, IMODE, K, $ RESULT( K ) NFAIL = NFAIL + 1 END IF 110 CONTINUE NRUN = NRUN + 7 * 90 CONTINUE 60 CONTINUE 70 CONTINUE 80 CONTINUE * * Print a summary of the results. * CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) * 9999 FORMAT( 1x, a6, ' M =', I5, ', N =', I5, ', NB =', I4, $ ', type ', I2, ', test ', I2, ', ratio =', G12.5 ) * * End if SCHKRR * END SHAR_EOF fi # end of overwriting check if test -f 'serrqp.f' then echo shar: will not over-write existing file "'serrqp.f'" else cat << SHAR_EOF > 'serrqp.f' SUBROUTINE SERRQP( PATH, NUNIT ) * * -- 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*3 PATH INTEGER NUNIT * .. * * Purpose * ======= * * SERRQP tests the error exits for SGEQPF. * * Arguments * ========= * * PATH (input) CHARACTER*3 * The LAPACK path name for the routines to be tested. * * NUNIT (input) INTEGER * The unit number for output. * * ===================================================================== * * .. Parameters .. INTEGER NMAX PARAMETER ( NMAX = 2 ) * .. * .. Local Scalars .. CHARACTER*2 C2 INTEGER INFO * .. * .. Local Arrays .. INTEGER IP( NMAX ) REAL A( NMAX, NMAX ), TAU( NMAX ), W( 3*NMAX ) * .. * .. External Functions .. LOGICAL LSAMEN EXTERNAL LSAMEN * .. * .. External Subroutines .. EXTERNAL ALAESM, CHKXER, SGEQPF * .. * .. Scalars in Common .. LOGICAL LERR, OK CHARACTER*6 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. COMMON / INFOC / INFOT, NOUT, OK, LERR COMMON / SRNAMC / SRNAMT * .. * .. Executable Statements .. * NOUT = NUNIT WRITE( NOUT, FMT = * ) C2 = PATH( 2: 3 ) A( 1, 1 ) = 1. A( 1, 2 ) = 2. A( 2, 2 ) = 3. A( 2, 1 ) = 4. OK = .TRUE. * IF( LSAMEN( 2, C2, 'QP' ) ) THEN * * Test error exits for QR factorization with pivoting * * SGEQPF * SRNAMT = 'SGEQPF' INFOT = 1 CALL SGEQPF( -1, 0, A, 1, IP, TAU, W, INFO ) CALL CHKXER( 'SGEQPF', INFOT, NOUT, LERR, OK ) INFOT = 2 CALL SGEQPF( 0, -1, A, 1, IP, TAU, W, INFO ) CALL CHKXER( 'SGEQPF', INFOT, NOUT, LERR, OK ) INFOT = 4 CALL SGEQPF( 2, 0, A, 1, IP, TAU, W, INFO ) CALL CHKXER( 'SGEQPF', INFOT, NOUT, LERR, OK ) END IF * * Print a summary line. * CALL ALAESM( PATH, OK, NOUT ) * RETURN * * End of SERRQP * END SHAR_EOF fi # end of overwriting check if test -f 'serrrr.f' then echo shar: will not over-write existing file "'serrrr.f'" else cat << SHAR_EOF > 'serrrr.f' SUBROUTINE SERRRR( PATH, NUNIT ) * * -- LAPACK test routine (version 1.0b) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * Rewritten for RRQR subroutines. * * .. Scalar Arguments .. CHARACTER*3 PATH INTEGER NUNIT * .. * * Purpose * ======= * * SERRRR tests the error exits for SGEQPX and SGEQPY. * * Arguments * ========= * * PATH (input) CHARACTER*3 * The LAPACK path name for the routines to be tested. * * NUNIT (input) INTEGER * The unit number for output. * * ===================================================================== * * .. Parameters .. INTEGER NMAX PARAMETER ( NMAX = 2 ) REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. CHARACTER*2 C2 INTEGER INFO, RANK, LW REAL IRCOND, ORCOND * .. * .. Local Arrays .. INTEGER IP( NMAX ) REAL A( NMAX, NMAX ), C( NMAX, NMAX ), $ SVLUES( 4 ), W( 2*NMAX+3*NMAX ) * .. * .. External Functions .. LOGICAL LSAMEN EXTERNAL LSAMEN * .. * .. External Subroutines .. EXTERNAL ALAESM, CHKXER, SGEQPX, SGEQPY * .. * .. Scalars in Common .. LOGICAL LERR, OK CHARACTER*6 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. COMMON / INFOC / INFOT, NOUT, OK, LERR COMMON / SRNAMC / SRNAMT * .. * .. Executable Statements .. * IRCOND = ZERO RANK = 1 LW = 2*NMAX+3*NMAX NOUT = NUNIT WRITE( NOUT, FMT = * ) C2 = PATH( 2: 3 ) A( 1, 1 ) = 1.0E+0 A( 1, 2 ) = 2.0E+0 A( 2, 2 ) = 3.0E+0 A( 2, 1 ) = 4.0E+0 OK = .TRUE. * IF( LSAMEN( 2, C2, 'RR' ) ) THEN * * Test error exits for Rank-Revealing QR factorization * * SGEQPX * SRNAMT = 'SGEQPX' INFOT = 1 CALL SGEQPX( 4, 0, 0, 0, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, INFO ) CALL CHKXER( 'SGEQPX', INFOT, NOUT, LERR, OK ) INFOT = 2 CALL SGEQPX( 1, -1, 0, 0, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, INFO ) CALL CHKXER( 'SGEQPX', INFOT, NOUT, LERR, OK ) INFOT = 3 CALL SGEQPX( 1, 0, -1, 0, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, INFO ) CALL CHKXER( 'SGEQPX', INFOT, NOUT, LERR, OK ) INFOT = 4 CALL SGEQPX( 1, 0, 0, -1, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, INFO ) CALL CHKXER( 'SGEQPX', INFOT, NOUT, LERR, OK ) INFOT = 6 CALL SGEQPX( 1, 2, 0, 0, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, INFO ) CALL CHKXER( 'SGEQPX', INFOT, NOUT, LERR, OK ) INFOT = 8 CALL SGEQPX( 2, 2, 0, 0, A, 2, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, INFO ) CALL CHKXER( 'SGEQPX', INFOT, NOUT, LERR, OK ) INFOT = 10 CALL SGEQPX( 1, 0, 0, 0, A, 1, C, 1, IP, -ONE, ORCOND, $ RANK, SVLUES, W, LW, INFO ) CALL CHKXER( 'SGEQPX', INFOT, NOUT, LERR, OK ) INFOT = 15 CALL SGEQPX( 1, 0, 1, 0, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, 2, INFO ) CALL CHKXER( 'SGEQPX', INFOT, NOUT, LERR, OK ) * * SGEQPY * SRNAMT = 'SGEQPY' INFOT = 1 CALL SGEQPY( 4, 0, 0, 0, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, INFO ) CALL CHKXER( 'SGEQPY', INFOT, NOUT, LERR, OK ) INFOT = 2 CALL SGEQPY( 1, -1, 0, 0, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, INFO ) CALL CHKXER( 'SGEQPY', INFOT, NOUT, LERR, OK ) INFOT = 3 CALL SGEQPY( 1, 0, -1, 0, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, INFO ) CALL CHKXER( 'SGEQPY', INFOT, NOUT, LERR, OK ) INFOT = 4 CALL SGEQPY( 1, 0, 0, -1, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, INFO ) CALL CHKXER( 'SGEQPY', INFOT, NOUT, LERR, OK ) INFOT = 6 CALL SGEQPY( 1, 2, 0, 0, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, INFO ) CALL CHKXER( 'SGEQPY', INFOT, NOUT, LERR, OK ) INFOT = 8 CALL SGEQPY( 2, 2, 0, 0, A, 2, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, INFO ) CALL CHKXER( 'SGEQPY', INFOT, NOUT, LERR, OK ) INFOT = 10 CALL SGEQPY( 1, 0, 0, 0, A, 1, C, 1, IP, -ONE, ORCOND, $ RANK, SVLUES, W, LW, INFO ) CALL CHKXER( 'SGEQPY', INFOT, NOUT, LERR, OK ) INFOT = 15 CALL SGEQPY( 1, 0, 1, 0, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, 2, INFO ) CALL CHKXER( 'SGEQPY', INFOT, NOUT, LERR, OK ) END IF * * Print a summary line. * CALL ALAESM( PATH, OK, NOUT ) * RETURN * * End of SERRRR * END SHAR_EOF fi # end of overwriting check if test -f 'slaord.f' then echo shar: will not over-write existing file "'slaord.f'" else cat << SHAR_EOF > 'slaord.f' SUBROUTINE SLAORD( JOB, N, X, INCX ) * * -- 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 * * .. Scalar Arguments .. CHARACTER JOB INTEGER INCX, N * .. * .. Array Arguments .. REAL X( * ) * .. * * Purpose * ======= * * SLAORD sorts the elements of a vector x in increasing or decreasing * order. * * Arguments * ========= * * JOB (input) CHARACTER * = 'I': Sort in increasing order * = 'D': Sort in decreasing order * * N (input) INTEGER * The length of the vector X. * * X (input/output) REAL array, dimension * (1+(N-1)*INCX) * On entry, the vector of length n to be sorted. * On exit, the vector x is sorted in the prescribed order. * * INCX (input) INTEGER * The spacing between successive elements of X. INCX >= 0. * * ===================================================================== * * .. Local Scalars .. INTEGER I, INC, IX, IXNEXT REAL TEMP * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. Executable Statements .. * INC = ABS( INCX ) IF( LSAME( JOB, 'I' ) ) THEN * * Sort in increasing order * DO 20 I = 2, N IX = 1 + ( I-1 )*INC 10 CONTINUE IF( IX.EQ.1 ) $ GO TO 20 IXNEXT = IX - INC IF( X( IX ).GT.X( IXNEXT ) ) THEN GO TO 20 ELSE TEMP = X( IX ) X( IX ) = X( IXNEXT ) X( IXNEXT ) = TEMP END IF IX = IXNEXT GO TO 10 20 CONTINUE * ELSE IF( LSAME( JOB, 'D' ) ) THEN * * Sort in decreasing order * DO 40 I = 2, N IX = 1 + ( I-1 )*INC 30 CONTINUE IF( IX.EQ.1 ) $ GO TO 40 IXNEXT = IX - INC IF( X( IX ).LT.X( IXNEXT ) ) THEN GO TO 40 ELSE TEMP = X( IX ) X( IX ) = X( IXNEXT ) X( IXNEXT ) = TEMP END IF IX = IXNEXT GO TO 30 40 CONTINUE END IF RETURN * * End of SLAORD * END SHAR_EOF fi # end of overwriting check if test -f 'sqpt01.f' then echo shar: will not over-write existing file "'sqpt01.f'" else cat << SHAR_EOF > 'sqpt01.f' REAL FUNCTION SQPT01( M, N, K, A, AF, LDA, TAU, JPVT, $ WORK, LWORK ) * * -- 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 .. INTEGER K, LDA, LWORK, M, N * .. * .. Array Arguments .. INTEGER JPVT( * ) REAL A( LDA, * ), AF( LDA, * ), TAU( * ), $ WORK( LWORK ) * .. * * Purpose * ======= * * SQPT01 tests the QR-factorization with pivoting of a matrix A. The * array AF contains the (possibly partial) QR-factorization of A, where * the upper triangle of AF(1:k,1:k) is a partial triangular factor, * the entries below the diagonal in the first k columns are the * Householder vectors, and the rest of AF contains a partially updated * matrix. * * This function returns ||A*P - Q*R||/(||norm(A)||*eps*M) * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrices A and AF. * * N (input) INTEGER * The number of columns of the matrices A and AF. * * K (input) INTEGER * The number of columns of AF that have been reduced * to upper triangular form. * * A (input) REAL array, dimension (LDA, N) * The original matrix A. * * AF (input) REAL array, dimension (LDA,N) * The (possibly partial) output of SGEQPF. The upper triangle * of AF(1:k,1:k) is a partial triangular factor, the entries * below the diagonal in the first k columns are the Householder * vectors, and the rest of AF contains a partially updated * matrix. * * LDA (input) INTEGER * The leading dimension of the arrays A and AF. * * TAU (input) REAL array, dimension (K) * Details of the Householder transformations as returned by * SGEQPF. * * JPVT (input) INTEGER array, dimension (N) * Pivot information as returned by SGEQPF. * * WORK (workspace) REAL array, dimension (LWORK) * * LWORK (input) INTEGER * The length of the array WORK. LWORK >= M*N+N. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) * .. * .. Local Scalars .. INTEGER I, INFO, J REAL NORMA * .. * .. Local Arrays .. REAL RWORK( 1 ) * .. * .. External Functions .. REAL SLAMCH, SLANGE EXTERNAL SLAMCH, SLANGE * .. * .. External Subroutines .. EXTERNAL SAXPY, SCOPY, SORMQR, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN, REAL * .. * .. Executable Statements .. * SQPT01 = ZERO * * Test if there is enough workspace * IF( LWORK.LT.M*N+N ) THEN CALL XERBLA( 'SQPT01', 10 ) RETURN END IF * * Quick return if possible * IF( M.LE.0 .OR. N.LE.0 ) $ RETURN * NORMA = SLANGE( 'One-norm', M, N, A, LDA, RWORK ) * DO 30 J = 1, K DO 10 I = 1, MIN( J, M ) WORK( ( J-1 )*M+I ) = AF( I, J ) 10 CONTINUE DO 20 I = J + 1, M WORK( ( J-1 )*M+I ) = ZERO 20 CONTINUE 30 CONTINUE DO 40 J = K + 1, N CALL SCOPY( M, AF( 1, J ), 1, WORK( ( J-1 )*M+1 ), 1 ) 40 CONTINUE * CALL SORMQR( 'Left', 'No transpose', M, N, K, AF, LDA, TAU, WORK, $ M, WORK( M*N+1 ), LWORK-M*N, INFO ) * DO 50 J = 1, N * * Compare i-th column of QR and jpvt(i)-th column of A * CALL SAXPY( M, -ONE, A( 1, JPVT( J ) ), 1, WORK( ( J-1 )*M+1 ), $ 1 ) 50 CONTINUE * SQPT01 = SLANGE( 'One-norm', M, N, WORK, M, RWORK ) / $ ( REAL( MAX( M, N ) )*SLAMCH( 'Epsilon' ) ) IF( NORMA.NE.ZERO ) $ SQPT01 = SQPT01 / NORMA * RETURN * * End of SQPT01 * END SHAR_EOF fi # end of overwriting check if test -f 'sqrt11.f' then echo shar: will not over-write existing file "'sqrt11.f'" else cat << SHAR_EOF > 'sqrt11.f' REAL FUNCTION SQRT11( M, K, A, LDA, TAU, WORK, LWORK ) * * -- LAPACK 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 K, LDA, LWORK, M * .. * .. Array Arguments .. REAL A( LDA, * ), TAU( * ), WORK( LWORK ) * .. * * Purpose * ======= * * SQRT11 computes the test ratio * * || Q'*Q - I || / (eps * m) * * where the orthogonal matrix Q is represented as a product of * elementary transformations. Each transformation has the form * * H(k) = I - tau(k) v(k) v(k)' * * where tau(k) is stored in TAU(k) and v(k) is an m-vector of the form * [ 0 ... 0 1 x(k) ]', where x(k) is a vector of length m-k stored * in A(k+1:m,k). * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. * * K (input) INTEGER * The number of columns of A whose subdiagonal entries * contain information about orthogonal transformations. * * A (input) REAL array, dimension (LDA,K) * The (possibly partial) output of a QR reduction routine. * * LDA (input) INTEGER * The leading dimension of the array A. * * TAU (input) REAL array, dimension (K) * The scaling factors tau for the elementary transformations as * computed by the QR factorization routine. * * WORK (workspace) REAL array, dimension (LWORK) * * LWORK (input) INTEGER * The length of the array WORK. LWORK >= M*M + M. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) * .. * .. Local Scalars .. INTEGER INFO, J * .. * .. External Functions .. REAL SLAMCH, SLANGE EXTERNAL SLAMCH, SLANGE * .. * .. External Subroutines .. EXTERNAL SLASET, SORM2R, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC REAL * .. * .. Local Arrays .. REAL RDUMMY( 1 ) * .. * .. Executable Statements .. * SQRT11 = ZERO * * Test for sufficient workspace * IF( LWORK.LT.M*M+M ) THEN CALL XERBLA( 'SQRT11', 7 ) RETURN END IF * * Quick return if possible * IF( M.LE.0 ) $ RETURN * CALL SLASET( 'Full', M, M, ZERO, ONE, WORK, M ) * * Form Q * CALL SORM2R( 'Left', 'No transpose', M, M, K, A, LDA, TAU, WORK, $ M, WORK( M*M+1 ), INFO ) * * Form Q'*Q * CALL SORM2R( 'Left', 'Transpose', M, M, K, A, LDA, TAU, WORK, M, $ WORK( M*M+1 ), INFO ) * DO 10 J = 1, M WORK( ( J-1 )*M+J ) = WORK( ( J-1 )*M+J ) - ONE 10 CONTINUE * SQRT11 = SLANGE( 'One-norm', M, M, WORK, M, RDUMMY ) / $ ( REAL( M )*SLAMCH( 'Epsilon' ) ) * RETURN * * End of SQRT11 * END SHAR_EOF fi # end of overwriting check if test -f 'sqrt12.f' then echo shar: will not over-write existing file "'sqrt12.f'" else cat << SHAR_EOF > 'sqrt12.f' REAL FUNCTION SQRT12( M, N, A, LDA, S, WORK, LWORK ) * * -- 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 .. INTEGER LDA, LWORK, M, N * .. * .. Array Arguments .. REAL A( LDA, * ), S( * ), WORK( LWORK ) * .. * * Purpose * ======= * * SQRT12 computes the singular values 'svlues' of the upper trapezoid * of A(1:M,1:N) and returns the ratio * * || s - svlues||/(||svlues||*eps*max(M,N)) * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. * * N (input) INTEGER * The number of columns of the matrix A. * * A (input) REAL array, dimension (LDA,N) * The M-by-N matrix A. Only the upper trapezoid is referenced. * * LDA (input) INTEGER * The leading dimension of the array A. * * S (input) REAL array, dimension (min(M,N)) * The singular values of the matrix A. * * WORK (workspace) REAL array, dimension (LWORK) * * LWORK (input) INTEGER * The length of the array WORK. LWORK >= M*N + 4*min(M,N) + * max(M,N). * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) * .. * .. Local Scalars .. INTEGER I, INFO, ISCL, J, MN REAL ANRM, BIGNUM, NRMSVL, SMLNUM * .. * .. External Functions .. REAL SASUM, SLAMCH, SLANGE, SNRM2 EXTERNAL SASUM, SLAMCH, SLANGE, SNRM2 * .. * .. External Subroutines .. EXTERNAL SAXPY, SBDSQR, SGEBD2, SLABAD, SLASCL, SLASET, $ XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN, REAL * .. * .. Local Arrays .. REAL DUMMY( 1 ) * .. * .. Executable Statements .. * SQRT12 = ZERO * * Test that enough workspace is supplied * IF( LWORK.LT.M*N+4*MIN( M, N )+MAX( M, N ) ) THEN CALL XERBLA( 'SQRT12', 7 ) RETURN END IF * * Quick return if possible * MN = MIN( M, N ) IF( MN.LE.ZERO ) $ RETURN * NRMSVL = SNRM2( MN, S, 1 ) * * Copy upper triangle of A into work * CALL SLASET( 'Full', M, N, ZERO, ZERO, WORK, M ) DO 20 J = 1, N DO 10 I = 1, MIN( J, M ) WORK( ( J-1 )*M+I ) = A( I, J ) 10 CONTINUE 20 CONTINUE * * Get machine parameters * SMLNUM = SLAMCH( 'S' ) / SLAMCH( 'P' ) BIGNUM = ONE / SMLNUM CALL SLABAD( SMLNUM, BIGNUM ) * * Scale work if max entry outside range [SMLNUM,BIGNUM] * ANRM = SLANGE( 'M', M, N, WORK, M, DUMMY ) ISCL = 0 IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN * * Scale matrix norm up to SMLNUM * CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, WORK, M, INFO ) ISCL = 1 ELSE IF( ANRM.GT.BIGNUM ) THEN * * Scale matrix norm down to BIGNUM * CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, WORK, M, INFO ) ISCL = 1 END IF * IF( ANRM.NE.ZERO ) THEN * * Compute SVD of work * CALL SGEBD2( M, N, WORK, M, WORK( M*N+1 ), WORK( M*N+MN+1 ), $ WORK( M*N+2*MN+1 ), WORK( M*N+3*MN+1 ), $ WORK( M*N+4*MN+1 ), INFO ) CALL SBDSQR( 'Upper', MN, 0, 0, 0, WORK( M*N+1 ), $ WORK( M*N+MN+1 ), DUMMY, MN, DUMMY, 1, DUMMY, MN, $ WORK( M*N+2*MN+1 ), INFO ) * IF( ISCL.EQ.1 ) THEN IF( ANRM.GT.BIGNUM ) THEN CALL SLASCL( 'G', 0, 0, BIGNUM, ANRM, MN, 1, $ WORK( M*N+1 ), MN, INFO ) END IF IF( ANRM.LT.SMLNUM ) THEN CALL SLASCL( 'G', 0, 0, SMLNUM, ANRM, MN, 1, $ WORK( M*N+1 ), MN, INFO ) END IF END IF * ELSE * DO 30 I = 1, MN WORK( M*N+I ) = ZERO 30 CONTINUE END IF * * Compare s and singular values of work * CALL SAXPY( MN, -ONE, S, 1, WORK( M*N+1 ), 1 ) SQRT12 = SASUM( MN, WORK( M*N+1 ), 1 ) / $ ( SLAMCH( 'Epsilon' )*REAL( MAX( M, N ) ) ) IF( NRMSVL.NE.ZERO ) $ SQRT12 = SQRT12 / NRMSVL * RETURN * * End of SQRT12 * END SHAR_EOF fi # end of overwriting check if test -f 'srrt01.f' then echo shar: will not over-write existing file "'srrt01.f'" else cat << SHAR_EOF > 'srrt01.f' REAL FUNCTION SRRT01( TRANS, M, N, A, LDA, JPVT, $ Q, LDQ, R, LDR, WORK, LWORK ) * * * * .. Scalar Arguments .. CHARACTER*1 TRANS INTEGER M, N, LDA, LDQ, LDR, LWORK * .. * .. Array Arguments .. INTEGER JPVT( * ) REAL A( LDA, * ), Q( LDQ, * ), R( LDR, * ), $ WORK( LWORK ) * .. * * Purpose * ======= * * SRRT01 tests the Rank-Revealing QR-factorization of matrix A. * Array A contains the original matrix being factorized. * Argument TRANS says if array Q contains matrix Q or Q' (its * transpose). * Array R contains matrix R. * * This function returns ||A*P - Q*R||/(||norm(A)||*eps*M) * * Arguments * ========= * * TRANS (input) CHARACTER*1 * If TRANS='N', then array Q contains matrix Q. * If TRANS='T', then array Q contains the transpose of * matrix Q. * * M (input) INTEGER * Number of rows of matrices A, R and Q, * and number of columns of Q. * * N (input) INTEGER * Number of columns of matrices A and R. * * A (input) REAL array, dimension (LDA, N) * Original m by n matrix A. * * JPVT (input) INTEGER array, dimension (N) * Pivot information as returned by SGERQR. * * Q (input) REAL array, dimension (LDQ,M) * Array which contains m by m orthogonal matrix Q * or its tranpose, according argument TRANS. * * R (input) REAL array, dimension (LDR,N) * Upper triangular matrix. * The lower part of matrix R must contain zeroes. * * LDR (input) INTEGER * Leading dimension of arrays A and R. * * WORK (workspace) REAL array, dimension (LWORK) * * LWORK (input) INTEGER * Length of array WORK. LWORK >= M*N. * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. INTEGER LDWORK, J REAL NORMA * .. * .. Local Arrays .. REAL RDUMMY( 1 ) * .. * .. External Functions .. LOGICAL LSAME REAL SLAMCH, SLANGE EXTERNAL SLAMCH, SLANGE, LSAME * .. * .. External Subroutines .. EXTERNAL SCOPY, XERBLA, SGEMM * .. * .. Intrinsic Functions .. INTRINSIC MAX, REAL * .. * .. Executable Statements .. * LDWORK = MAX( 1, M ) * * Test if there is enough workspace * IF( LWORK.LT.M*N ) THEN CALL XERBLA( 'SRRT01', 10 ) RETURN END IF * * Quick return if possible * IF( M.LE.0 .OR. N.LE.0 ) THEN SRRT01 = ZERO RETURN END IF * NORMA = SLANGE( 'One-norm', M, N, A, LDA, RDUMMY ) * * Compute WORK := A*P. * DO J = 1, N CALL SCOPY( M, A( 1, JPVT( J ) ), 1, $ WORK( (J-1)*M+1 ), 1 ) END DO * * Compute WORK := WORK - Q*R. * IF( LSAME( TRANS, 'N' ) ) THEN CALL SGEMM( 'No transpose', 'No transpose', M, N, M, -ONE, $ Q, LDQ, R, LDR, ONE, WORK, LDWORK ) ELSE CALL SGEMM( 'Transpose', 'No transpose', M, N, M, -ONE, $ Q, LDQ, R, LDR, ONE, WORK, LDWORK ) END IF * * Compute the 1-norm of WORK divided by (max(m,n)*eps). * SRRT01 = SLANGE( 'One-norm', M, N, WORK, LDWORK, $ RDUMMY ) / $ ( REAL( MAX( M, N ) )*SLAMCH( 'Epsilon' ) ) IF( NORMA.NE.ZERO ) $ SRRT01 = SRRT01 / NORMA * RETURN * * End of SRRT01 * END SHAR_EOF fi # end of overwriting check if test -f 'srrt02.f' then echo shar: will not over-write existing file "'srrt02.f'" else cat << SHAR_EOF > 'srrt02.f' REAL FUNCTION SRRT02( M, QT, LDQT, WORK, LWORK ) * * * * .. Scalar Arguments .. INTEGER M, LDQT, LWORK * .. * .. Array Arguments .. REAL QT( LDQT, * ), WORK( LWORK ) * .. * * Purpose * ======= * * SRRT02 computes the test ratio * * || Q'*Q - I || / (eps * m) * * where the transpose of matrix Q (Q') is stored in array QT. * * * Arguments * ========= * * M (input) INTEGER * Number of rows and columns of matrix QT. * * QT (input) REAL array, dimension (LDQT,N) * Transpose of m by m matrix Q. * * LDQT (input) INTEGER * Leading dimension of array QT. * * WORK (workspace) REAL array, dimension (LWORK) * * LWORK (input) INTEGER * The length of the array WORK. LWORK >= M*M. * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. INTEGER LDWORK * .. * .. External Functions .. REAL SLAMCH, SLANGE EXTERNAL SLAMCH, SLANGE * .. * .. External Subroutines .. EXTERNAL SLASET, XERBLA, SGEMM * .. * .. Intrinsic Functions .. INTRINSIC MAX, REAL * .. * .. Local Arrays .. REAL RDUMMY( 1 ) * .. * .. Executable Statements .. * LDWORK = MAX( 1, M ) * * Test for sufficient workspace * IF( LWORK.LT.M*M ) THEN CALL XERBLA( 'SRRT02', 7 ) RETURN END IF * * Quick return if possible * IF( M.LE.0 ) THEN SRRT02 = ZERO RETURN END IF * * Set WORK to the identity. * CALL SLASET( 'All',M, M, ZERO, ONE, WORK, LDWORK ) * * Compute WORK := WORK - QT * QT'. That is, WORK := WORK - Q'*Q. * CALL SGEMM( 'No transpose', 'Transpose', M, M, M, -ONE, $ QT, LDQT, QT, LDQT, ONE, WORK, LDWORK ) * * Compute || WORK || / ( m * eps ). * SRRT02 = SLANGE( 'One-norm', M, M, WORK, LDWORK, RDUMMY )/ $ ( REAL( M )*SLAMCH( 'Epsilon' ) ) * RETURN * * End of SRRT02 * END SHAR_EOF fi # end of overwriting check if test -f 'xerbla.f' then echo shar: will not over-write existing file "'xerbla.f'" else cat << SHAR_EOF > 'xerbla.f' SUBROUTINE XERBLA( SRNAME, INFO ) * * -- 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 * * .. Scalar Arguments .. CHARACTER*6 SRNAME INTEGER INFO * .. * * Purpose * ======= * * This is a special version of XERBLA to be used only as part of * the test program for testing error exits from the LAPACK routines. * Error messages are printed if INFO.NE.INFOT or if SRNAME.NE.SRMANT, * where INFOT and SRNAMT are values stored in COMMON. * * Arguments * ========= * * SRNAME (input) CHARACTER*6 * The name of the subroutine calling XERBLA. This name should * match the COMMON variable SRNAMT. * * INFO (input) INTEGER * The error return code from the calling subroutine. INFO * should equal the COMMON variable INFOT. * * Further Details * ======= ======= * * The following variables are passed via the common blocks INFOC and * SRNAMC: * * INFOT INTEGER Expected integer return code * NOUT INTEGER Unit number for printing error messages * OK LOGICAL Set to .TRUE. if INFO = INFOT and * SRNAME = SRNAMT, otherwise set to .FALSE. * LERR LOGICAL Set to .TRUE., indicating that XERBLA was called * SRNAMT CHARACTER*6 Expected name of calling subroutine * * * .. Scalars in Common .. LOGICAL LERR, OK CHARACTER*6 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. COMMON / INFOC / INFOT, NOUT, OK, LERR COMMON / SRNAMC / SRNAMT * .. * .. Executable Statements .. * LERR = .TRUE. IF( INFO.NE.INFOT ) THEN IF( INFOT.NE.0 ) THEN WRITE( NOUT, FMT = 9999 )SRNAMT, INFO, INFOT ELSE WRITE( NOUT, FMT = 9997 )SRNAME, INFO END IF OK = .FALSE. END IF IF( SRNAME.NE.SRNAMT ) THEN WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT OK = .FALSE. END IF RETURN * 9999 FORMAT( ' *** XERBLA was called from ', A6, ' with INFO = ', I6, $ ' instead of ', I2, ' ***' ) 9998 FORMAT( ' *** XERBLA was called with SRNAME = ', A6, $ ' instead of ', A6, ' ***' ) 9997 FORMAT( ' *** On entry to ', A6, ' parameter number ', I6, $ ' had an illegal value ***' ) * * End of XERBLA * END SHAR_EOF fi # end of overwriting check if test -f 'xlaenv.f' then echo shar: will not over-write existing file "'xlaenv.f'" else cat << SHAR_EOF > 'xlaenv.f' SUBROUTINE XLAENV( ISPEC, NVALUE ) * * -- 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 * * .. Scalar Arguments .. INTEGER ISPEC, NVALUE * .. * * Purpose * ======= * * XLAENV sets certain machine- and problem-dependent quantities * which will later be retrieved by ILAENV. * * Arguments * ========= * * ISPEC (input) INTEGER * Specifies the parameter to be set in the COMMON array IPARMS. * = 1: the optimal blocksize; if this value is 1, an unblocked * algorithm will give the best performance. * = 2: the minimum block size for which the block routine * should be used; if the usable block size is less than * this value, an unblocked routine should be used. * = 3: the crossover point (in a block routine, for N less * than this value, an unblocked routine should be used) * = 4: the number of shifts, used in the nonsymmetric * eigenvalue routines * = 5: the minimum column dimension for blocking to be used; * rectangular blocks must have dimension at least k by m, * where k is given by ILAENV(2,...) and m by ILAENV(5,...) * = 6: the crossover point for the SVD (when reducing an m by n * matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds * this value, a QR factorization is used first to reduce * the matrix to a triangular form) * = 7: the number of processors * = 8: another crossover point, for the multishift QR and QZ * methods for nonsymmetric eigenvalue problems. * * NVALUE (input) INTEGER * The value of the parameter specified by ISPEC. * * ===================================================================== * * .. Arrays in Common .. INTEGER IPARMS( 100 ) * .. * .. Common blocks .. COMMON / CLAENV / IPARMS * .. * .. Save statement .. SAVE / CLAENV / * .. * .. Executable Statements .. * IF( ISPEC.GE.1 .AND. ISPEC.LE.8 ) THEN IPARMS( ISPEC ) = NVALUE END IF * RETURN * * End of XLAENV * END SHAR_EOF fi # end of overwriting check if test -f 'zchkaa.f' then echo shar: will not over-write existing file "'zchkaa.f'" else cat << SHAR_EOF > 'zchkaa.f' PROGRAM ZCHKAA * * -- 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 * * Purpose * ======= * * ZCHKAA is the main test program for the COMPLEX*16 linear * equation routines. * * An annotated example of a data file can be obtained by deleting the * first 3 characters from the following lines: * Data file for testing COMPLEX*16 LAPACK linear equation routines * 7 Number of values of M * 0 1 2 3 5 10 16 Values of M (row dimension) * 7 Number of values of N * 0 1 2 3 5 10 16 Values of N (column dimension) * 5 Number of values of NB * 1 3 3 3 20 Values of NB (the blocksize) * 1 0 5 9 1 Values of NX (crossover point) * 30.0 Threshold value of test ratio * T Put T to test the LAPACK routines * T Put T to test the driver routines * T Put T to test the error exits * ZQP 6 List types on next line if 0 < NTYPES < 6 * ZRR 3 List types on next line if 0 < NTYPES < 3 * * Internal Parameters * =================== * * NMAX INTEGER * The maximum allowable value for N. * * MAXIN INTEGER * The number of different values that can be used for each of * M, N, or NB * * MAXRHS INTEGER * The maximum number of right hand sides * * NIN INTEGER * The unit number for input * * NOUT INTEGER * The unit number for output * * LWORK INTEGER * The workspace length * * ===================================================================== * * .. Parameters .. INTEGER NMAX PARAMETER ( NMAX = 501 ) INTEGER MAXIN PARAMETER ( MAXIN = 12 ) INTEGER MAXRHS PARAMETER ( MAXRHS = 10 ) INTEGER MATMAX PARAMETER ( MATMAX = 30 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER KDMAX PARAMETER ( KDMAX = NMAX+( NMAX+1 ) / 4 ) * INTEGER LWORK PARAMETER ( LWORK = NMAX*( NMAX+MAXRHS ) ) * .. * .. Local Scalars .. LOGICAL FATAL, TSTCHK, TSTERR CHARACTER C1 CHARACTER*2 C2 CHARACTER*3 PATH CHARACTER*10 INTSTR CHARACTER*72 ALINE INTEGER I, IC, J, K, LDA, NB, NM, NMATS, NN, $ NNB, NNB2, NTYPES DOUBLE PRECISION EPS, S1, S2, THREQ, THRESH * .. * .. Local Arrays .. LOGICAL DOTYPE( MATMAX ) INTEGER IWORK( 3*NMAX ), MVAL( MAXIN ), NBVAL( MAXIN ), $ NBVAL2( MAXIN ), NVAL( MAXIN ), NXVAL( MAXIN ) DOUBLE PRECISION RWORK( 5*NMAX+2*MAXRHS ), S( 2*NMAX ) COMPLEX*16 A( ( KDMAX+1 )*NMAX, 7 ), B( NMAX*MAXRHS, 4 ), $ WORK( NMAX, NMAX+MAXRHS ) * .. * .. External Functions .. LOGICAL LSAME, LSAMEN DOUBLE PRECISION DLAMCH, DSECND EXTERNAL LSAME, LSAMEN, DLAMCH, DSECND * .. * .. External Subroutines .. EXTERNAL ALAREQ, ZCHKQP, ZCHKRR * .. * .. Scalars in Common .. LOGICAL LERR, OK CHARACTER*6 SRNAMT INTEGER INFOT, NUNIT * .. * .. Arrays in Common .. INTEGER IPARMS( 100 ) * .. * .. Common blocks .. COMMON / INFOC / INFOT, NUNIT, OK, LERR COMMON / SRNAMC / SRNAMT COMMON / CLAENV / IPARMS * .. * .. Data statements .. DATA THREQ / 2.0D0 / , INTSTR / '0123456789' / * .. * .. Executable Statements .. * S1 = DSECND( ) LDA = NMAX FATAL = .FALSE. * * Read a dummy line. * READ( NIN, FMT = * ) * * Report values of parameters. * WRITE( NOUT, FMT = 9993 ) * * Read the values of M * READ( NIN, FMT = * )NM IF( NM.LT.1 ) THEN WRITE( NOUT, FMT = 9996 )' NM ', NM, 1 NM = 0 FATAL = .TRUE. ELSE IF( NM.GT.MAXIN ) THEN WRITE( NOUT, FMT = 9995 )' NM ', NM, MAXIN NM = 0 FATAL = .TRUE. END IF READ( NIN, FMT = * )( MVAL( I ), I = 1, NM ) DO 10 I = 1, NM IF( MVAL( I ).LT.0 ) THEN WRITE( NOUT, FMT = 9996 )' M ', MVAL( I ), 0 FATAL = .TRUE. ELSE IF( MVAL( I ).GT.NMAX ) THEN WRITE( NOUT, FMT = 9995 )' M ', MVAL( I ), NMAX FATAL = .TRUE. END IF 10 CONTINUE IF( NM.GT.0 ) $ WRITE( NOUT, FMT = 9992 )'M ', ( MVAL( I ), I = 1, NM ) * * Read the values of N * READ( NIN, FMT = * )NN IF( NN.LT.1 ) THEN WRITE( NOUT, FMT = 9996 )' NN ', NN, 1 NN = 0 FATAL = .TRUE. ELSE IF( NN.GT.MAXIN ) THEN WRITE( NOUT, FMT = 9995 )' NN ', NN, MAXIN NN = 0 FATAL = .TRUE. END IF READ( NIN, FMT = * )( NVAL( I ), I = 1, NN ) DO 20 I = 1, NN IF( NVAL( I ).LT.0 ) THEN WRITE( NOUT, FMT = 9996 )' N ', NVAL( I ), 0 FATAL = .TRUE. ELSE IF( NVAL( I ).GT.NMAX ) THEN WRITE( NOUT, FMT = 9995 )' N ', NVAL( I ), NMAX FATAL = .TRUE. END IF 20 CONTINUE IF( NN.GT.0 ) $ WRITE( NOUT, FMT = 9992 )'N ', ( NVAL( I ), I = 1, NN ) * * Read the values of NB * READ( NIN, FMT = * )NNB IF( NNB.LT.1 ) THEN WRITE( NOUT, FMT = 9996 )'NNB ', NNB, 1 NNB = 0 FATAL = .TRUE. ELSE IF( NNB.GT.MAXIN ) THEN WRITE( NOUT, FMT = 9995 )'NNB ', NNB, MAXIN NNB = 0 FATAL = .TRUE. END IF READ( NIN, FMT = * )( NBVAL( I ), I = 1, NNB ) DO 40 I = 1, NNB IF( NBVAL( I ).LT.0 ) THEN WRITE( NOUT, FMT = 9996 )' NB ', NBVAL( I ), 0 FATAL = .TRUE. END IF 40 CONTINUE IF( NNB.GT.0 ) $ WRITE( NOUT, FMT = 9992 )'NB ', ( NBVAL( I ), I = 1, NNB ) * * Set NBVAL2 to be the set of unique values of NB * NNB2 = 0 DO 60 I = 1, NNB NB = NBVAL( I ) DO 50 J = 1, NNB2 IF( NB.EQ.NBVAL2( J ) ) $ GO TO 60 50 CONTINUE NNB2 = NNB2 + 1 NBVAL2( NNB2 ) = NB 60 CONTINUE * * Read the values of NX * READ( NIN, FMT = * )( NXVAL( I ), I = 1, NNB ) DO 70 I = 1, NNB IF( NXVAL( I ).LT.0 ) THEN WRITE( NOUT, FMT = 9996 )' NX ', NXVAL( I ), 0 FATAL = .TRUE. END IF 70 CONTINUE IF( NNB.GT.0 ) $ WRITE( NOUT, FMT = 9992 )'NX ', ( NXVAL( I ), I = 1, NNB ) * * Read the threshold value for the test ratios. * READ( NIN, FMT = * )THRESH WRITE( NOUT, FMT = 9991 )THRESH * * Read the flag that indicates whether to test the LAPACK routines. * READ( NIN, FMT = * )TSTCHK * * Read the flag that indicates whether to test the error exits. * READ( NIN, FMT = * )TSTERR * IF( FATAL ) THEN WRITE( NOUT, FMT = 9999 ) STOP END IF * * Calculate and print the machine dependent constants. * EPS = DLAMCH( 'Underflow threshold' ) WRITE( NOUT, FMT = 9990 )'underflow', EPS EPS = DLAMCH( 'Overflow threshold' ) WRITE( NOUT, FMT = 9990 )'overflow ', EPS EPS = DLAMCH( 'Epsilon' ) WRITE( NOUT, FMT = 9990 )'precision', EPS WRITE( NOUT, FMT = * ) * 80 CONTINUE * * Read a test path and the number of matrix types to use. * READ( NIN, FMT = '(A72)', END = 140 )ALINE PATH = ALINE( 1: 3 ) NMATS = MATMAX I = 3 90 CONTINUE I = I + 1 IF( I.GT.72 ) $ GO TO 130 IF( ALINE( I: I ).EQ.' ' ) $ GO TO 90 NMATS = 0 100 CONTINUE C1 = ALINE( I: I ) DO 110 K = 1, 10 IF( C1.EQ.INTSTR( K: K ) ) THEN IC = K - 1 GO TO 120 END IF 110 CONTINUE GO TO 130 120 CONTINUE NMATS = NMATS*10 + IC I = I + 1 IF( I.GT.72 ) $ GO TO 130 GO TO 100 130 CONTINUE C1 = PATH( 1: 1 ) C2 = PATH( 2: 3 ) * * Check first character for correct precision. * IF( .NOT.LSAME( C1, 'Z precision' ) ) THEN WRITE( NOUT, FMT = 9989 )PATH * ELSE IF( NMATS.LE.0 ) THEN * * Check for a positive number of tests requested. * WRITE( NOUT, FMT = 9988 )PATH * ELSE IF( LSAMEN( 2, C2, 'QP' ) ) THEN * * QP: QR factorization with pivoting * NTYPES = 6 CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) * IF( TSTCHK ) THEN CALL ZCHKQP( DOTYPE, NM, MVAL, NN, NVAL, THRESH, $ TSTERR, A( 1, 1 ), A( 1, 2 ), S( 1 ), $ S( NMAX+1 ), B( 1, 1 ), WORK, RWORK, IWORK, $ NOUT ) ELSE WRITE( NOUT, FMT = 9988 )PATH END IF * ELSE IF( LSAMEN( 2, C2, 'RR' ) ) THEN * * RR: Rank-Revealing QR factorization * NTYPES = 3 CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) * IF( TSTCHK ) THEN CALL ZCHKRR( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, $ NXVAL, THRESH, TSTERR, A( 1, 1 ), A( 1, 2 ), $ A( 1, 3 ), S( 1 ), S( NMAX+1 ), $ WORK, LWORK, RWORK, IWORK, NOUT ) ELSE WRITE( NOUT, FMT = 9988 )PATH END IF * ELSE * WRITE( NOUT, FMT = 9989 )PATH END IF * * Go back to get another input line. * GO TO 80 * * Branch to this line when the last record is read. * 140 CONTINUE CLOSE ( NIN ) S2 = DSECND( ) WRITE( NOUT, FMT = 9998 ) WRITE( NOUT, FMT = 9997 )S2 - S1 * 9999 FORMAT( / ' Execution not attempted due to input errors' ) 9998 FORMAT( / ' End of tests' ) 9997 FORMAT( ' Total time used = ', F12.2, ' seconds', / ) 9996 FORMAT( ' Invalid input value: ', A4, '=', I6, '; must be >=', $ I6 ) 9995 FORMAT( ' Invalid input value: ', A4, '=', I6, '; must be <=', $ I6 ) 9993 FORMAT( ' RRQR Tests. COMPLEX*16 LAPACK routines ', $ / / ' The following parameter values will be used:' ) 9992 FORMAT( 4X, A4, ': ', 10I6, / 11X, 10I6 ) 9991 FORMAT( / ' Routines pass computational tests if test ratio is ', $ 'less than', F8.2, / ) 9990 FORMAT( ' Relative machine ', A, ' is taken to be', D16.6 ) 9989 FORMAT( / 1X, A3, ': Unrecognized path name' ) 9988 FORMAT( / 1X, A3, ' routines were not tested' ) * * End of ZCHKAA * END SHAR_EOF fi # end of overwriting check if test -f 'zchkqp.f' then echo shar: will not over-write existing file "'zchkqp.f'" else cat << SHAR_EOF > 'zchkqp.f' SUBROUTINE ZCHKQP( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A, $ COPYA, S, COPYS, TAU, WORK, RWORK, IWORK, $ NOUT ) * * -- 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 .. LOGICAL TSTERR INTEGER NM, NN, NOUT DOUBLE PRECISION THRESH * .. * .. Array Arguments .. LOGICAL DOTYPE( * ) INTEGER IWORK( * ), MVAL( * ), NVAL( * ) DOUBLE PRECISION COPYS( * ), RWORK( * ), S( * ) COMPLEX*16 A( * ), COPYA( * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZCHKQP tests ZGEQPF. * * Arguments * ========= * * DOTYPE (input) LOGICAL array, dimension (NTYPES) * The matrix types to be used for testing. Matrices of type j * (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = * .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. * * NM (input) INTEGER * The number of values of M contained in the vector MVAL. * * MVAL (input) INTEGER array, dimension (NM) * The values of the matrix row dimension M. * * NN (input) INTEGER * The number of values of N contained in the vector NVAL. * * NVAL (input) INTEGER array, dimension (NN) * The values of the matrix column dimension N. * * THRESH (input) DOUBLE PRECISION * The threshold value for the test ratios. A result is * included in the output file if RESULT >= THRESH. To have * every test ratio printed, use THRESH = 0. * * TSTERR (input) LOGICAL * Flag that indicates whether error exits are to be tested. * * A (workspace) COMPLEX*16 array, dimension (MMAX*NMAX) * where MMAX is the maximum value of M in MVAL and NMAX is the * maximum value of N in NVAL. * * COPYA (workspace) COMPLEX*16 array, dimension (MMAX*NMAX) * * S (workspace) DOUBLE PRECISION array, dimension * (min(MMAX,NMAX)) * * COPYS (workspace) DOUBLE PRECISION array, dimension * (min(MMAX,NMAX)) * * TAU (workspace) COMPLEX*16 array, dimension (MMAX) * * WORK (workspace) COMPLEX*16 array, dimension * (max(M*max(M,N) + 4*min(M,N) + max(M,N))) * * RWORK (workspace) DOUBLE PRECISION array, dimension (4*NMAX) * * IWORK (workspace) INTEGER array, dimension (NMAX) * * NOUT (input) INTEGER * The unit number for output. * * ===================================================================== * * .. Parameters .. INTEGER NTYPES PARAMETER ( NTYPES = 6 ) INTEGER NTESTS PARAMETER ( NTESTS = 3 ) DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) * .. * .. Local Scalars .. CHARACTER*3 PATH INTEGER I, IHIGH, ILOW, IM, IMODE, IN, INFO, ISTEP, K, $ LDA, LWORK, M, MNMIN, MODE, N, NERRS, NFAIL, $ NRUN DOUBLE PRECISION EPS * .. * .. Local Arrays .. INTEGER ISEED( 4 ), ISEEDY( 4 ) DOUBLE PRECISION RESULT( NTESTS ) * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, ZQPT01, ZQRT11, ZQRT12 EXTERNAL DLAMCH, ZQPT01, ZQRT11, ZQRT12 * .. * .. External Subroutines .. EXTERNAL ALAHD, ALASUM, DLAORD, ZERRQP, ZGEQPF, ZLACPY, $ ZLASET, ZLATMS * .. * .. Intrinsic Functions .. INTRINSIC DCMPLX, MAX, MIN * .. * .. Scalars in Common .. LOGICAL LERR, OK CHARACTER*6 SRNAMT INTEGER INFOT, IOUNIT * .. * .. Common blocks .. COMMON / INFOC / INFOT, IOUNIT, OK, LERR COMMON / SRNAMC / SRNAMT * .. * .. Data statements .. DATA ISEEDY / 1988, 1989, 1990, 1991 / * .. * .. Executable Statements .. * * Initialize constants and the random number seed. * PATH( 1: 1 ) = 'Z' PATH( 2: 3 ) = 'QP' NRUN = 0 NFAIL = 0 NERRS = 0 DO 10 I = 1, 4 ISEED( I ) = ISEEDY( I ) 10 CONTINUE EPS = DLAMCH( 'Epsilon' ) * * Test the error exits * IF( TSTERR ) $ CALL ZERRQP( PATH, NOUT ) INFOT = 0 * DO 80 IM = 1, NM * * Do for each value of M in MVAL. * M = MVAL( IM ) LDA = MAX( 1, M ) * DO 70 IN = 1, NN * * Do for each value of N in NVAL. * N = NVAL( IN ) MNMIN = MIN( M, N ) LWORK = MAX( 1, M*MAX( M, N )+4*MNMIN+MAX( M, N ) ) * DO 60 IMODE = 1, NTYPES IF( .NOT.DOTYPE( IMODE ) ) $ GO TO 60 * * Do for each type of matrix * 1: zero matrix * 2: one small singular value * 3: geometric distribution of singular values * 4: first n/2 columns fixed * 5: last n/2 columns fixed * 6: every second column fixed * MODE = IMODE IF( IMODE.GT.3 ) $ MODE = 1 * * Generate test matrix of size m by n using * singular value distribution indicated by 'mode'. * DO 20 I = 1, N IWORK( I ) = 0 20 CONTINUE IF( IMODE.EQ.1 ) THEN CALL ZLASET( 'Full', M, N, DCMPLX( ZERO ), $ DCMPLX( ZERO ), COPYA, LDA ) DO 30 I = 1, MNMIN COPYS( I ) = ZERO 30 CONTINUE ELSE CALL ZLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', COPYS, $ MODE, ONE / EPS, ONE, M, N, 'No packing', $ COPYA, LDA, WORK, INFO ) IF( IMODE.GE.4 ) THEN IF( IMODE.EQ.4 ) THEN ILOW = 1 ISTEP = 1 IHIGH = MAX( 1, N / 2 ) ELSE IF( IMODE.EQ.5 ) THEN ILOW = MAX( 1, N / 2 ) ISTEP = 1 IHIGH = N ELSE IF( IMODE.EQ.6 ) THEN ILOW = 1 ISTEP = 2 IHIGH = N END IF DO 40 I = ILOW, IHIGH, ISTEP IWORK( I ) = 1 40 CONTINUE END IF CALL DLAORD( 'Decreasing', MNMIN, COPYS, 1 ) END IF * * Save A and its singular values * CALL ZLACPY( 'All', M, N, COPYA, LDA, A, LDA ) * * Compute the QR factorization with pivoting of A * SRNAMT = 'ZGEQPF' CALL ZGEQPF( M, N, A, LDA, IWORK, TAU, WORK, RWORK, $ INFO ) * * Compute norm(svd(a) - svd(r)) * RESULT( 1 ) = ZQRT12( M, N, A, LDA, COPYS, WORK, LWORK, $ RWORK ) * * Compute norm( A*P - Q*R ) * RESULT( 2 ) = ZQPT01( M, N, MNMIN, COPYA, A, LDA, TAU, $ IWORK, WORK, LWORK ) * * Compute Q'*Q * RESULT( 3 ) = ZQRT11( M, MNMIN, A, LDA, TAU, WORK, $ LWORK ) * * Print information about the tests that did not pass * the threshold. * DO 50 K = 1, 3 IF( RESULT( K ).GE.THRESH ) THEN IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) $ CALL ALAHD( NOUT, PATH ) WRITE( NOUT, FMT = 9999 )M, N, IMODE, K, $ RESULT( K ) NFAIL = NFAIL + 1 END IF 50 CONTINUE NRUN = NRUN + 3 60 CONTINUE 70 CONTINUE 80 CONTINUE * * Print a summary of the results. * CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) * 9999 FORMAT( ' M =', I5, ', N =', I5, ', type ', I2, ', test ', I2, $ ', ratio =', G12.5 ) * * End of ZCHKQP * END SHAR_EOF fi # end of overwriting check if test -f 'zchkrr.f' then echo shar: will not over-write existing file "'zchkrr.f'" else cat << SHAR_EOF > 'zchkrr.f' SUBROUTINE ZCHKRR( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, $ NXVAL, THRESH, TSTERR, A, AQ, COPYA, S, COPYS, $ WORK, LNWK, RWORK, IWORK, NOUT ) * * -- 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 * * Rewritten to test RRQR Subroutines. * * .. Scalar Arguments .. LOGICAL TSTERR INTEGER LNWK, NM, NN, NNB, NOUT DOUBLE PRECISION THRESH * .. * .. Array Arguments .. LOGICAL DOTYPE( * ) INTEGER IWORK( * ), MVAL( * ), NVAL( * ), $ NBVAL( * ), NXVAL( * ) DOUBLE PRECISION COPYS( * ), RWORK( * ), S( * ) COMPLEX*16 A( * ), AQ( * ), COPYA( * ), WORK( * ) * .. * * Purpose * ======= * * ZCHKRR tests ZGEQPX and ZGEQPY. * * Arguments * ========= * * DOTYPE (input) LOGICAL array, dimension (NTYPES) * The matrix types to be used for testing. Matrices of type j * (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = * .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. * * NM (input) INTEGER * The number of values of M contained in the vector MVAL. * * MVAL (input) INTEGER array, dimension (NM) * The values of the matrix row dimension M. * * NN (input) INTEGER * The number of values of N contained in the vector NVAL. * * NVAL (input) INTEGER array, dimension (NN) * The values of the matrix column dimension N. * * NNB (input) INTEGER * The number of values of NB and NX contained in the * vectors NBVAL and NXVAL. The blocking parameters are used * in pairs (NB,NX). * * NBVAL (input) INTEGER array, dimension (NNB) * The values of the blocksize NB. * * NXVAL (input) INTEGER array, dimension (NNB) * The values of the crossover point NX. * * THRESH (input) DOUBLE PRECISION * The threshold value for the test ratios. A result is * included in the output file if RESULT >= THRESH. To have * every test ratio printed, use THRESH = 0. * * TSTERR (input) LOGICAL * Flag that indicates whether error exits are to be tested. * * A (workspace) COMPLEX*16 array, dimension (MMAX*NMAX) * where MMAX is the maximum value of M in MVAL and NMAX is the * maximum value of N in NVAL. * * AQ (workspace) COMPLEX*16 array, dimension (MMAX*NMAX) * where MMAX is the maximum value of M in MVAL and NMAX is the * maximum value of N in NVAL. * * COPYA (workspace) COMPLEX*16 array, dimension (MMAX*NMAX) * * S (workspace) DOUBLE PRECISION array, dimension * (min(MMAX,NMAX)) * * COPYS (workspace) DOUBLE PRECISION array, dimension * (min(MMAX,NMAX)) * * WORK (workspace) COMPLEX*16 array, dimension (LNWK) * * LNWK (input) INTEGER * Workspace length. At least * ((max(M*max(M,N) + 4*min(M,N) + max(M,N))). * * RWORK (workspace) DOUBLE PRECISION array, dimension (4*NMAX) * * IWORK (workspace) INTEGER array, dimension (NMAX) * * NOUT (input) INTEGER * The unit number for output. * * ===================================================================== * * .. Parameters .. INTEGER NTYPES PARAMETER ( NTYPES = 3 ) INTEGER NTESTS PARAMETER ( NTESTS = 14 ) DOUBLE PRECISION ONE, ZERO COMPLEX*16 CONE, CZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0, $ CONE = ( 1.0D+0, 0.0D+0 ), $ CZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. CHARACTER*3 PATH INTEGER I, IM, IMODE, IN, INB, INFO, K, $ LDA, LW, LWORK, M, MNMIN, N, NB, NERRS, NFAIL, $ NRUN, NX, RANK DOUBLE PRECISION EPS, IRCOND, ORCOND * .. * .. Local Arrays .. INTEGER ISEED( 4 ), ISEEDY( 4 ) DOUBLE PRECISION RESULT( NTESTS ), SVLUES( 4 ) * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, ZQRT12, ZRRT01, $ ZRRT02 EXTERNAL DLAMCH, ZQRT12, ZRRT01, $ ZRRT02 * .. * .. External Subroutines .. EXTERNAL ALAHD, ALASUM, DLAORD, ZERRRR, $ ZGEQPX, ZGEQPY, $ ZLACPY, ZLASET, ZLATMS * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Scalars in Common .. LOGICAL LERR, OK CHARACTER*6 SRNAMT INTEGER INFOT, IOUNIT * .. * .. Common blocks .. COMMON / INFOC / INFOT, IOUNIT, OK, LERR COMMON / SRNAMC / SRNAMT * .. * .. Data statements .. DATA ISEEDY / 1988, 1989, 1990, 1991 / * .. * .. Executable Statements .. * * Initialize constants and the random number seed. * PATH( 1: 1 ) = 'Z' PATH( 2: 3 ) = 'RR' NRUN = 0 NFAIL = 0 NERRS = 0 DO 10 I = 1, 4 ISEED( I ) = ISEEDY( I ) 10 CONTINUE EPS = DLAMCH( 'Epsilon' ) IRCOND = EPS * * Test the error exits * IF( TSTERR ) $ CALL ZERRRR( PATH, NOUT ) INFOT = 0 * DO 80 IM = 1, NM * * Do for each value of M in MVAL. * M = MVAL( IM ) LDA = MAX( 1, M ) * DO 70 IN = 1, NN * * Do for each value of N in NVAL. * N = NVAL( IN ) MNMIN = MIN( M, N ) LWORK = MAX( 1, M*MAX( M, N )+4*MNMIN+MAX( M, N ) ) * * Check if there is enough workspace. * IF( LWORK.GT.LNWK ) THEN WRITE(*,*) ' Error in ZCHKRR.', 'Code 1:', $ ' Actual Workspace:', LNWK, $ ' Needed Workspace :', LWORK STOP ENDIF * DO 60 IMODE = 1, NTYPES IF( .NOT.DOTYPE( IMODE ) ) $ GO TO 60 * * Do for each type of matrix * 1: zero matrix * 2: one small singular value * 3: geometric distribution of singular values * * Generate test matrix of size m by n using * singular value distribution indicated by 'mode'. * IF( IMODE.EQ.1 ) THEN CALL ZLASET( 'Full', M, N, CZERO, CZERO, COPYA, $ LDA ) DO 30 I = 1, MNMIN COPYS( I ) = ZERO 30 CONTINUE ELSE CALL ZLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', $ COPYS, IMODE, ONE / EPS, ONE, M, N, $ 'No packing', COPYA, LDA, WORK, INFO ) CALL DLAORD( 'Decreasing', MNMIN, COPYS, 1 ) END IF * DO 90 INB = 1, NNB * * Do for each pair of values (NB,NX) in NBVAL and NXVAL. * NB = NBVAL( INB ) CALL XLAENV( 1, NB ) NX = NXVAL( INB ) CALL XLAENV( 3, NX ) * * ****************** * * Testing yGEQPX * * ****************** * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Test yGEQPX when JOB=1 * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Get a work copy of matrix A from COPYA. * CALL ZLACPY( 'All', M, N, COPYA, LDA, A, LDA ) * * Compute the Rank-Revealing QR factorization of A * IF ( NB.LT.3 ) THEN LW = MAX( 1, 2*MNMIN+N ) ELSE LW = MAX( 1, 2*MNMIN+N*NB ) END IF * * Check if there is enough workspace for current * block size. * IF( LW.GT.LNWK ) THEN WRITE(*,*) ' Error in PREC_CHKRR.', 'Code 2', $ ' Workspace too short for blocksize',nb WRITE(*,*) ' Actual Workspace:', LNWK, $ ' Needed Workspace :', LW STOP ENDIF * SRNAMT = 'ZGEQPX' CALL ZGEQPX( 1, M, N, 0, A, LDA, AQ, LDA, IWORK, $ IRCOND, ORCOND, RANK, SVLUES, WORK, LW, $ RWORK, INFO ) * * Compute norm(svd(a) - svd(r)) * RESULT( 1 ) = ZQRT12( M, N, A, LDA, COPYS, WORK, $ LWORK, RWORK ) * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Test yGEQPX when JOB=2 * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Get a work copy of matrix A from COPYA. * CALL ZLACPY( 'All', M, N, COPYA, LDA, A, LDA ) * * Set WORK to identity. * CALL ZLASET( 'All', M, M, CZERO, CONE, AQ, LDA ) * * Compute the Rank-Revealing QR factorization of A * IF ( NB.LT.3 ) THEN LW = MAX( 1, 2*MNMIN+MAX(N,M) ) ELSE LW = MAX( 1, 2*MNMIN+NB*NB+NB*MAX(N,M) ) END IF SRNAMT = 'ZGEQPX' CALL ZGEQPX( 2, M, N, M, A, LDA, AQ, LDA, IWORK, $ IRCOND, ORCOND, RANK, SVLUES, WORK, LW, $ RWORK, INFO ) * * Compute norm(svd(a) - svd(r)) * RESULT( 2 ) = ZQRT12( M, N, A, LDA, COPYS, WORK, $ LWORK, RWORK ) * * Compute norm( A*P - Q*R ) * RESULT( 3 ) = ZRRT01( 'Conjugate Transpose', $ M, N, COPYA, LDA, IWORK, $ AQ, LDA, A, LDA, WORK, LWORK ) * * Compute norm( Q'*Q - Identity ) * RESULT( 4 ) = ZRRT02( M, AQ, LDA, WORK, LWORK ) * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Test yGEQPX when JOB=3 * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Get a work copy of matrix A from COPYA. * CALL ZLACPY( 'All', M, N, COPYA, LDA, A, LDA ) * * Set WORK to identity. * CALL ZLASET( 'All', M, M, CZERO, CONE, AQ, LDA ) * * Compute the Rank-Revealing QR factorization of A * IF ( NB.LT.3 ) THEN LW = MAX( 1, 2*MNMIN+MAX(N,M) ) ELSE LW = MAX( 1, 2*MNMIN+NB*NB+NB*MAX(N,M) ) END IF SRNAMT = 'ZGEQPX' CALL ZGEQPX( 3, M, N, M, A, LDA, AQ, LDA, IWORK, $ IRCOND, ORCOND, RANK, SVLUES, WORK, LW, $ RWORK, INFO ) * * Compute norm(svd(a) - svd(r)) * RESULT( 5 ) = ZQRT12( M, N, A, LDA, COPYS, WORK, $ LWORK, RWORK ) * * Compute norm( A*P - Q*R ) * RESULT( 6 ) = ZRRT01( 'No transpose', M, N, $ COPYA, LDA, IWORK, $ AQ, LDA, A, LDA, WORK, LWORK ) * * Compute norm( Q'*Q - Identity ) * RESULT( 7 ) = ZRRT02( M, AQ, LDA, WORK, LWORK ) * * * *-*-*-*-*-*-*-*-*-*-* * * Printing results * * *-*-*-*-*-*-*-*-*-*-* * * Print information about the tests that did not pass * the threshold. * DO 100 K = 1, 7 IF( RESULT( K ).GE.THRESH ) THEN IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) $ CALL ALAHD( NOUT, PATH ) WRITE( NOUT, FMT = 9999 ) 'ZGEQPX', M, N, $ NB, IMODE, K, $ RESULT( K ) NFAIL = NFAIL + 1 END IF 100 CONTINUE NRUN = NRUN + 7 * * * ****************** * * Testing yGEQPY * * ****************** * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Test yGEQPY when JOB=1 * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Get a work copy of matrix A from COPYA. * CALL ZLACPY( 'All', M, N, COPYA, LDA, A, LDA ) * * Compute the Rank-Revealing QR factorization of A * IF ( NB.LT.3 ) THEN LW = MAX( 1, 2*MNMIN+N ) ELSE LW = MAX( 1, 2*MNMIN+N*NB ) END IF * * Check if there is enough workspace for current * block size. * IF( LW.GT.LNWK ) THEN WRITE(*,*) ' Error in PREC_CHKRR.', 'Code 2', $ ' Workspace too short for blocksize',nb WRITE(*,*) ' Actual Workspace:', LNWK, $ ' Needed Workspace :', LW STOP ENDIF * SRNAMT = 'ZGEQPY' CALL ZGEQPY( 1, M, N, 0, A, LDA, AQ, LDA, IWORK, $ IRCOND, ORCOND, RANK, SVLUES, WORK, LW, $ RWORK, INFO ) * * Compute norm(svd(a) - svd(r)) * RESULT( 8 ) = ZQRT12( M, N, A, LDA, COPYS, WORK, $ LWORK, RWORK ) * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Test yGEQPY when JOB=2 * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Get a work copy of matrix A from COPYA. * CALL ZLACPY( 'All', M, N, COPYA, LDA, A, LDA ) * * Set WORK to identity. * CALL ZLASET( 'All', M, M, CZERO, CONE, AQ, LDA ) * * Compute the Rank-Revealing QR factorization of A * IF ( NB.LT.3 ) THEN LW = MAX( 1, 2*MNMIN+MAX(N,M) ) ELSE LW = MAX( 1, 2*MNMIN+NB*NB+NB*MAX(N,M) ) END IF SRNAMT = 'ZGEQPY' CALL ZGEQPY( 2, M, N, M, A, LDA, AQ, LDA, IWORK, $ IRCOND, ORCOND, RANK, SVLUES, WORK, LW, $ RWORK, INFO ) * * Compute norm(svd(a) - svd(r)) * RESULT( 9 ) = ZQRT12( M, N, A, LDA, COPYS, WORK, $ LWORK, RWORK ) * * Compute norm( A*P - Q*R ) * RESULT( 10 ) = ZRRT01( 'Conjugate Transpose', $ M, N, COPYA, LDA, IWORK, $ AQ, LDA, A, LDA, WORK, LWORK ) * * Compute norm( Q'*Q - Identity ) * RESULT( 11 ) = ZRRT02( M, AQ, LDA, WORK, LWORK ) * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Test yGEQPY when JOB=3 * * *-*-*-*-*-*-*-*-*-*-*-*-*-* * * Get a work copy of matrix A from COPYA. * CALL ZLACPY( 'All', M, N, COPYA, LDA, A, LDA ) * * Set WORK to identity. * CALL ZLASET( 'All', M, M, CZERO, CONE, AQ, LDA ) * * Compute the Rank-Revealing QR factorization of A * IF ( NB.LT.3 ) THEN LW = MAX( 1, 2*MNMIN+MAX(N,M) ) ELSE LW = MAX( 1, 2*MNMIN+NB*NB+NB*MAX(N,M) ) END IF SRNAMT = 'ZGEQPY' CALL ZGEQPY( 3, M, N, M, A, LDA, AQ, LDA, IWORK, $ IRCOND, ORCOND, RANK, SVLUES, WORK, LW, $ RWORK, INFO ) * * Compute norm(svd(a) - svd(r)) * RESULT( 12 ) = ZQRT12( M, N, A, LDA, COPYS, WORK, $ LWORK, RWORK ) * * Compute norm( A*P - Q*R ) * RESULT( 13 ) = ZRRT01( 'No transpose', M, N, $ COPYA, LDA, IWORK, $ AQ, LDA, A, LDA, WORK, LWORK ) * * Compute norm( Q'*Q - Identity ) * RESULT( 14 ) = ZRRT02( M, AQ, LDA, WORK, LWORK ) * * * *-*-*-*-*-*-*-*-*-*-* * * Printing results * * *-*-*-*-*-*-*-*-*-*-* * * Print information about the tests that did not pass * the threshold. * DO 110 K = 8, 14 IF( RESULT( K ).GE.THRESH ) THEN IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) $ CALL ALAHD( NOUT, PATH ) WRITE( NOUT, FMT = 9999 ) 'ZGEQPY', M, N, $ NB, IMODE, K, $ RESULT( K ) NFAIL = NFAIL + 1 END IF 110 CONTINUE NRUN = NRUN + 7 * 90 CONTINUE 60 CONTINUE 70 CONTINUE 80 CONTINUE * * Print a summary of the results. * CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) * 9999 FORMAT( 1x, a6, ' M =', I5, ', N =', I5, ', NB =', I4, $ ', type ', I2, ', test ', I2, ', ratio =', G12.5 ) * * End of ZCHKRR * END SHAR_EOF fi # end of overwriting check if test -f 'zerrqp.f' then echo shar: will not over-write existing file "'zerrqp.f'" else cat << SHAR_EOF > 'zerrqp.f' SUBROUTINE ZERRQP( PATH, NUNIT ) * * -- 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*3 PATH INTEGER NUNIT * .. * * Purpose * ======= * * ZERRQP tests the error exits for ZGEQPF. * * Arguments * ========= * * PATH (input) CHARACTER*3 * The LAPACK path name for the routines to be tested. * * NUNIT (input) INTEGER * The unit number for output. * * ===================================================================== * * .. Parameters .. INTEGER NMAX PARAMETER ( NMAX = 2 ) * .. * .. Local Scalars .. CHARACTER*2 C2 INTEGER INFO * .. * .. Local Arrays .. INTEGER IP( NMAX ) DOUBLE PRECISION RW( 2*NMAX ) COMPLEX*16 A( NMAX, NMAX ), TAU( NMAX ), W( NMAX ) * .. * .. External Functions .. LOGICAL LSAMEN EXTERNAL LSAMEN * .. * .. External Subroutines .. EXTERNAL ALAESM, CHKXER, ZGEQPF * .. * .. Scalars in Common .. LOGICAL LERR, OK CHARACTER*6 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. COMMON / INFOC / INFOT, NOUT, OK, LERR COMMON / SRNAMC / SRNAMT * .. * .. Intrinsic Functions .. INTRINSIC DCMPLX * .. * .. Executable Statements .. * NOUT = NUNIT C2 = PATH( 2: 3 ) A( 1, 1 ) = DCMPLX( 1.D0, -1.D0 ) A( 1, 2 ) = DCMPLX( 2.D0, -2.D0 ) A( 2, 2 ) = DCMPLX( 3.D0, -3.D0 ) A( 2, 1 ) = DCMPLX( 4.D0, -4.D0 ) OK = .TRUE. WRITE( NOUT, FMT = * ) * * Test error exits for QR factorization with pivoting * IF( LSAMEN( 2, C2, 'QP' ) ) THEN * * ZGEQPF * SRNAMT = 'ZGEQPF' INFOT = 1 CALL ZGEQPF( -1, 0, A, 1, IP, TAU, W, RW, INFO ) CALL CHKXER( 'ZGEQPF', INFOT, NOUT, LERR, OK ) INFOT = 2 CALL ZGEQPF( 0, -1, A, 1, IP, TAU, W, RW, INFO ) CALL CHKXER( 'ZGEQPF', INFOT, NOUT, LERR, OK ) INFOT = 4 CALL ZGEQPF( 2, 0, A, 1, IP, TAU, W, RW, INFO ) CALL CHKXER( 'ZGEQPF', INFOT, NOUT, LERR, OK ) END IF * * Print a summary line. * CALL ALAESM( PATH, OK, NOUT ) * RETURN * * End of ZERRQP * END SHAR_EOF fi # end of overwriting check if test -f 'zerrrr.f' then echo shar: will not over-write existing file "'zerrrr.f'" else cat << SHAR_EOF > 'zerrrr.f' SUBROUTINE ZERRRR( PATH, NUNIT ) * * -- LAPACK test routine (version 1.0b) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * Rewritten for new least-squares solvers. * * .. Scalar Arguments .. CHARACTER*3 PATH INTEGER NUNIT * .. * * Purpose * ======= * * ZERRRR tests the error exits for ZGEQPX and ZGEQPY. * * Arguments * ========= * * PATH (input) CHARACTER*3 * The LAPACK path name for the routines to be tested. * * NUNIT (input) INTEGER * The unit number for output. * * ===================================================================== * * .. Parameters .. INTEGER NMAX PARAMETER ( NMAX = 2 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. CHARACTER*2 C2 INTEGER INFO, RANK, LW DOUBLE PRECISION IRCOND, ORCOND * .. * .. Local Arrays .. INTEGER IP( NMAX ) DOUBLE PRECISION SVLUES( 4 ), RW( 2*NMAX ) COMPLEX*16 A( NMAX, NMAX ), C( NMAX, NMAX ), $ W( 2*NMAX+3*NMAX ) * .. * .. External Functions .. LOGICAL LSAMEN EXTERNAL LSAMEN * .. * .. External Subroutines .. EXTERNAL ALAESM, CHKXER, ZGEQPX * .. * .. Scalars in Common .. LOGICAL LERR, OK CHARACTER*6 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. COMMON / INFOC / INFOT, NOUT, OK, LERR COMMON / SRNAMC / SRNAMT * .. * .. Executable Statements .. * IRCOND = ZERO RANK = 1 LW = 2*NMAX+3*NMAX NOUT = NUNIT WRITE( NOUT, FMT = * ) C2 = PATH( 2: 3 ) A( 1, 1 ) = ( 1.0D+0, 0.0D+0 ) A( 1, 2 ) = ( 2.0D+0, 0.0D+0 ) A( 2, 2 ) = ( 3.0D+0, 0.0D+0 ) A( 2, 1 ) = ( 4.0D+0, 0.0D+0 ) OK = .TRUE. * IF( LSAMEN( 2, C2, 'RR' ) ) THEN * * Test error exits for Rank-Revealing QR factorization * * ZGEQPX * SRNAMT = 'ZGEQPX' INFOT = 1 CALL ZGEQPX( 4, 0, 0, 0, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, RW, INFO ) CALL CHKXER( 'ZGEQPX', INFOT, NOUT, LERR, OK ) INFOT = 2 CALL ZGEQPX( 1, -1, 0, 0, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, RW, INFO ) CALL CHKXER( 'ZGEQPX', INFOT, NOUT, LERR, OK ) INFOT = 3 CALL ZGEQPX( 1, 0, -1, 0, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, RW, INFO ) CALL CHKXER( 'ZGEQPX', INFOT, NOUT, LERR, OK ) INFOT = 4 CALL ZGEQPX( 1, 0, 0, -1, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, RW, INFO ) CALL CHKXER( 'ZGEQPX', INFOT, NOUT, LERR, OK ) INFOT = 6 CALL ZGEQPX( 1, 2, 0, 0, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, RW, INFO ) CALL CHKXER( 'ZGEQPX', INFOT, NOUT, LERR, OK ) INFOT = 8 CALL ZGEQPX( 2, 2, 0, 0, A, 2, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, RW, INFO ) CALL CHKXER( 'ZGEQPX', INFOT, NOUT, LERR, OK ) INFOT = 10 CALL ZGEQPX( 1, 0, 0, 0, A, 1, C, 1, IP, -ONE, ORCOND, $ RANK, SVLUES, W, LW, RW, INFO ) CALL CHKXER( 'ZGEQPX', INFOT, NOUT, LERR, OK ) INFOT = 15 CALL ZGEQPX( 1, 0, 3, 0, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, 2, RW, INFO ) CALL CHKXER( 'ZGEQPX', INFOT, NOUT, LERR, OK ) * * ZGEQPY * SRNAMT = 'ZGEQPY' INFOT = 1 CALL ZGEQPY( 4, 0, 0, 0, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, RW, INFO ) CALL CHKXER( 'ZGEQPY', INFOT, NOUT, LERR, OK ) INFOT = 2 CALL ZGEQPY( 1, -1, 0, 0, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, RW, INFO ) CALL CHKXER( 'ZGEQPY', INFOT, NOUT, LERR, OK ) INFOT = 3 CALL ZGEQPY( 1, 0, -1, 0, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, RW, INFO ) CALL CHKXER( 'ZGEQPY', INFOT, NOUT, LERR, OK ) INFOT = 4 CALL ZGEQPY( 1, 0, 0, -1, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, RW, INFO ) CALL CHKXER( 'ZGEQPY', INFOT, NOUT, LERR, OK ) INFOT = 6 CALL ZGEQPY( 1, 2, 0, 0, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, RW, INFO ) CALL CHKXER( 'ZGEQPY', INFOT, NOUT, LERR, OK ) INFOT = 8 CALL ZGEQPY( 2, 2, 0, 0, A, 2, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, LW, RW, INFO ) CALL CHKXER( 'ZGEQPY', INFOT, NOUT, LERR, OK ) INFOT = 10 CALL ZGEQPY( 1, 0, 0, 0, A, 1, C, 1, IP, -ONE, ORCOND, $ RANK, SVLUES, W, LW, RW, INFO ) CALL CHKXER( 'ZGEQPY', INFOT, NOUT, LERR, OK ) INFOT = 15 CALL ZGEQPY( 1, 0, 3, 0, A, 1, C, 1, IP, IRCOND, ORCOND, $ RANK, SVLUES, W, 2, RW, INFO ) CALL CHKXER( 'ZGEQPY', INFOT, NOUT, LERR, OK ) END IF * * Print a summary line. * CALL ALAESM( PATH, OK, NOUT ) * RETURN * * End of ZERRRR * END SHAR_EOF fi # end of overwriting check if test -f 'zqpt01.f' then echo shar: will not over-write existing file "'zqpt01.f'" else cat << SHAR_EOF > 'zqpt01.f' DOUBLE PRECISION FUNCTION ZQPT01( M, N, K, A, AF, LDA, TAU, JPVT, $ WORK, LWORK ) * * -- 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 .. INTEGER K, LDA, LWORK, M, N * .. * .. Array Arguments .. INTEGER JPVT( * ) COMPLEX*16 A( LDA, * ), AF( LDA, * ), TAU( * ), $ WORK( LWORK ) * .. * * Purpose * ======= * * ZQPT01 tests the QR-factorization with pivoting of a matrix A. The * array AF contains the (possibly partial) QR-factorization of A, where * the upper triangle of AF(1:k,1:k) is a partial triangular factor, * the entries below the diagonal in the first k columns are the * Householder vectors, and the rest of AF contains a partially updated * matrix. * * This function returns ||A*P - Q*R||/(||norm(A)||*eps*M) * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrices A and AF. * * N (input) INTEGER * The number of columns of the matrices A and AF. * * K (input) INTEGER * The number of columns of AF that have been reduced * to upper triangular form. * * A (input) COMPLEX*16 array, dimension (LDA, N) * The original matrix A. * * AF (input) COMPLEX*16 array, dimension (LDA,N) * The (possibly partial) output of ZGEQPF. The upper triangle * of AF(1:k,1:k) is a partial triangular factor, the entries * below the diagonal in the first k columns are the Householder * vectors, and the rest of AF contains a partially updated * matrix. * * LDA (input) INTEGER * The leading dimension of the arrays A and AF. * * TAU (input) COMPLEX*16 array, dimension (K) * Details of the Householder transformations as returned by * ZGEQPF. * * JPVT (input) INTEGER array, dimension (N) * Pivot information as returned by ZGEQPF. * * WORK (workspace) COMPLEX*16 array, dimension (LWORK) * * LWORK (input) INTEGER * The length of the array WORK. LWORK >= M*N+N. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. INTEGER I, INFO, J DOUBLE PRECISION NORMA * .. * .. Local Arrays .. DOUBLE PRECISION RWORK( 1 ) * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, ZLANGE EXTERNAL DLAMCH, ZLANGE * .. * .. External Subroutines .. EXTERNAL XERBLA, ZAXPY, ZCOPY, ZUNMQR * .. * .. Intrinsic Functions .. INTRINSIC DBLE, DCMPLX, MAX, MIN * .. * .. Executable Statements .. * ZQPT01 = ZERO * * Test if there is enough workspace * IF( LWORK.LT.M*N+N ) THEN CALL XERBLA( 'ZQPT01', 10 ) RETURN END IF * * Quick return if possible * IF( M.LE.0 .OR. N.LE.0 ) $ RETURN * NORMA = ZLANGE( 'One-norm', M, N, A, LDA, RWORK ) * DO 30 J = 1, K DO 10 I = 1, MIN( J, M ) WORK( ( J-1 )*M+I ) = AF( I, J ) 10 CONTINUE DO 20 I = J + 1, M WORK( ( J-1 )*M+I ) = ZERO 20 CONTINUE 30 CONTINUE DO 40 J = K + 1, N CALL ZCOPY( M, AF( 1, J ), 1, WORK( ( J-1 )*M+1 ), 1 ) 40 CONTINUE * CALL ZUNMQR( 'Left', 'No transpose', M, N, K, AF, LDA, TAU, WORK, $ M, WORK( M*N+1 ), LWORK-M*N, INFO ) * DO 50 J = 1, N * * Compare i-th column of QR and jpvt(i)-th column of A * CALL ZAXPY( M, DCMPLX( -ONE ), A( 1, JPVT( J ) ), 1, $ WORK( ( J-1 )*M+1 ), 1 ) 50 CONTINUE * ZQPT01 = ZLANGE( 'One-norm', M, N, WORK, M, RWORK ) / $ ( DBLE( MAX( M, N ) )*DLAMCH( 'Epsilon' ) ) IF( NORMA.NE.ZERO ) $ ZQPT01 = ZQPT01 / NORMA * RETURN * * End of ZQPT01 * END SHAR_EOF fi # end of overwriting check if test -f 'zqrt11.f' then echo shar: will not over-write existing file "'zqrt11.f'" else cat << SHAR_EOF > 'zqrt11.f' DOUBLE PRECISION FUNCTION ZQRT11( M, K, A, LDA, TAU, WORK, LWORK ) * * -- LAPACK 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 K, LDA, LWORK, M * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), TAU( * ), WORK( LWORK ) * .. * * Purpose * ======= * * ZQRT11 computes the test ratio * * || Q'*Q - I || / (eps * m) * * where the orthogonal matrix Q is represented as a product of * elementary transformations. Each transformation has the form * * H(k) = I - tau(k) v(k) v(k)' * * where tau(k) is stored in TAU(k) and v(k) is an m-vector of the form * [ 0 ... 0 1 x(k) ]', where x(k) is a vector of length m-k stored * in A(k+1:m,k). * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. * * K (input) INTEGER * The number of columns of A whose subdiagonal entries * contain information about orthogonal transformations. * * A (input) COMPLEX*16 array, dimension (LDA,K) * The (possibly partial) output of a QR reduction routine. * * LDA (input) INTEGER * The leading dimension of the array A. * * TAU (input) COMPLEX*16 array, dimension (K) * The scaling factors tau for the elementary transformations as * computed by the QR factorization routine. * * WORK (workspace) COMPLEX*16 array, dimension (LWORK) * * LWORK (input) INTEGER * The length of the array WORK. LWORK >= M*M + M. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. INTEGER INFO, J * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, ZLANGE EXTERNAL DLAMCH, ZLANGE * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLASET, ZUNM2R * .. * .. Intrinsic Functions .. INTRINSIC DBLE, DCMPLX * .. * .. Local Arrays .. DOUBLE PRECISION RDUMMY( 1 ) * .. * .. Executable Statements .. * ZQRT11 = ZERO * * Test for sufficient workspace * IF( LWORK.LT.M*M+M ) THEN CALL XERBLA( 'ZQRT11', 7 ) RETURN END IF * * Quick return if possible * IF( M.LE.0 ) $ RETURN * CALL ZLASET( 'Full', M, M, DCMPLX( ZERO ), DCMPLX( ONE ), WORK, $ M ) * * Form Q * CALL ZUNM2R( 'Left', 'No transpose', M, M, K, A, LDA, TAU, WORK, $ M, WORK( M*M+1 ), INFO ) * * Form Q'*Q * CALL ZUNM2R( 'Left', 'Conjugate transpose', M, M, K, A, LDA, TAU, $ WORK, M, WORK( M*M+1 ), INFO ) * DO 10 J = 1, M WORK( ( J-1 )*M+J ) = WORK( ( J-1 )*M+J ) - ONE 10 CONTINUE * ZQRT11 = ZLANGE( 'One-norm', M, M, WORK, M, RDUMMY ) / $ ( DBLE( M )*DLAMCH( 'Epsilon' ) ) * RETURN * * End of ZQRT11 * END SHAR_EOF fi # end of overwriting check if test -f 'zqrt12.f' then echo shar: will not over-write existing file "'zqrt12.f'" else cat << SHAR_EOF > 'zqrt12.f' DOUBLE PRECISION FUNCTION ZQRT12( M, N, A, LDA, S, WORK, LWORK, $ RWORK ) * * -- 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 .. INTEGER LDA, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION RWORK( * ), S( * ) COMPLEX*16 A( LDA, * ), WORK( LWORK ) * .. * * Purpose * ======= * * ZQRT12 computes the singular values 'svlues' of the upper trapezoid * of A(1:M,1:N) and returns the ratio * * || s - svlues||/(||svlues||*eps*max(M,N)) * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. * * N (input) INTEGER * The number of columns of the matrix A. * * A (input) COMPLEX*16 array, dimension (LDA,N) * The M-by-N matrix A. Only the upper trapezoid is referenced. * * LDA (input) INTEGER * The leading dimension of the array A. * * S (input) DOUBLE PRECISION array, dimension (min(M,N)) * The singular values of the matrix A. * * WORK (workspace) COMPLEX*16 array, dimension (LWORK) * * LWORK (input) INTEGER * The length of the array WORK. LWORK >= M*N + 2*min(M,N) + * max(M,N). * * RWORK (workspace) DOUBLE PRECISION array, dimension (2*min(M,N)) * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. INTEGER I, INFO, ISCL, J, MN DOUBLE PRECISION ANRM, BIGNUM, NRMSVL, SMLNUM * .. * .. Local Arrays .. DOUBLE PRECISION DUMMY( 1 ) * .. * .. External Functions .. DOUBLE PRECISION DASUM, DLAMCH, DNRM2, ZLANGE EXTERNAL DASUM, DLAMCH, DNRM2, ZLANGE * .. * .. External Subroutines .. EXTERNAL DAXPY, DBDSQR, DLABAD, DLASCL, XERBLA, ZGEBD2, $ ZLASCL, ZLASET * .. * .. Intrinsic Functions .. INTRINSIC DBLE, DCMPLX, MAX, MIN * .. * .. Executable Statements .. * ZQRT12 = ZERO * * Test that enough workspace is supplied * IF( LWORK.LT.M*N+2*MIN( M, N )+MAX( M, N ) ) THEN CALL XERBLA( 'ZQRT12', 7 ) RETURN END IF * * Quick return if possible * MN = MIN( M, N ) IF( MN.LE.ZERO ) $ RETURN * NRMSVL = DNRM2( MN, S, 1 ) * * Copy upper triangle of A into work * CALL ZLASET( 'Full', M, N, DCMPLX( ZERO ), DCMPLX( ZERO ), WORK, $ M ) DO 20 J = 1, N DO 10 I = 1, MIN( J, M ) WORK( ( J-1 )*M+I ) = A( I, J ) 10 CONTINUE 20 CONTINUE * * Get machine parameters * SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) * * Scale work if max entry outside range [SMLNUM,BIGNUM] * ANRM = ZLANGE( 'M', M, N, WORK, M, DUMMY ) ISCL = 0 IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN * * Scale matrix norm up to SMLNUM * CALL ZLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, WORK, M, INFO ) ISCL = 1 ELSE IF( ANRM.GT.BIGNUM ) THEN * * Scale matrix norm down to BIGNUM * CALL ZLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, WORK, M, INFO ) ISCL = 1 END IF * IF( ANRM.NE.ZERO ) THEN * * Compute SVD of work * CALL ZGEBD2( M, N, WORK, M, RWORK( 1 ), RWORK( MN+1 ), $ WORK( M*N+1 ), WORK( M*N+MN+1 ), $ WORK( M*N+2*MN+1 ), INFO ) CALL DBDSQR( 'Upper', MN, 0, 0, 0, RWORK( 1 ), RWORK( MN+1 ), $ DUMMY, MN, DUMMY, 1, DUMMY, MN, RWORK( 2*MN+1 ), $ INFO ) * IF( ISCL.EQ.1 ) THEN IF( ANRM.GT.BIGNUM ) THEN CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MN, 1, RWORK( 1 ), $ MN, INFO ) END IF IF( ANRM.LT.SMLNUM ) THEN CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MN, 1, RWORK( 1 ), $ MN, INFO ) END IF END IF * ELSE * DO 30 I = 1, MN RWORK( I ) = ZERO 30 CONTINUE END IF * * Compare s and singular values of work * CALL DAXPY( MN, -ONE, S, 1, RWORK( 1 ), 1 ) ZQRT12 = DASUM( MN, RWORK( 1 ), 1 ) / $ ( DLAMCH( 'Epsilon' )*DBLE( MAX( M, N ) ) ) IF( NRMSVL.NE.ZERO ) $ ZQRT12 = ZQRT12 / NRMSVL * RETURN * * End of ZQRT12 * END SHAR_EOF fi # end of overwriting check if test -f 'zrrt01.f' then echo shar: will not over-write existing file "'zrrt01.f'" else cat << SHAR_EOF > 'zrrt01.f' DOUBLE PRECISION FUNCTION ZRRT01( CNJTRN, M, N, A, LDA, JPVT, $ Q, LDQ, R, LDR, WORK, LWORK ) * * * * .. Scalar Arguments .. CHARACTER*1 CNJTRN INTEGER M, N, LDA, LDQ, LDR, LWORK * .. * .. Array Arguments .. INTEGER JPVT( * ) COMPLEX*16 A( LDA, * ), Q( LDQ, * ), R( LDR, * ), $ WORK( LWORK ) * .. * * Purpose * ======= * * ZRRT01 tests the Rank-Revealing QR-factorization of matrix A. * Array A contains the original matrix being factorized. * Argument TRANS says if array Q contains matrix Q or its conjugate * transpose. * Array R contains matrix R. * * This function returns ||A*P - Q*R||/(||norm(A)||*eps*M) * * Arguments * ========= * * TRANS (input) CHARACTER*1 * If TRANS='N', then array Q contains matrix Q. * If TRANS='T', then array Q contains the conjugate transpose * of matrix Q. * * M (input) INTEGER * Number of rows of matrices A, R and Q, * and number of columns of Q. * * N (input) INTEGER * Number of columns of matrices A and R. * * A (input) COMPLEX*16 array, dimension (LDA, N) * Original m by n matrix A. * * JPVT (input) INTEGER array, dimension (N) * Pivot information as returned by ZGERQR. * * Q (input) COMPLEX*16 array, dimension (LDQ,M) * Array which contains m by m orthogonal matrix Q * or its tranpose, according argument TRANS. * * R (input) COMPLEX*16 array, dimension (LDR,N) * Upper triangular matrix. * The lower part of matrix R must contain zeroes. * * LDR (input) INTEGER * Leading dimension of arrays A and R. * * WORK (workspace) COMPLEX*16 array, dimension (LWORK) * * LWORK (input) INTEGER * Length of array WORK. LWORK >= M*N. * * .. Parameters .. DOUBLE PRECISION ZERO, ONE COMPLEX*16 CZERO, CONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, $ CZERO = ( 0.0D+0, 0.0D+0 ), $ CONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER LDWORK, J DOUBLE PRECISION NORMA * .. * .. Local Arrays .. DOUBLE PRECISION RDUMMY( 1 ) * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, ZLANGE EXTERNAL LSAME, DLAMCH, DLANGE * .. * .. External Subroutines .. EXTERNAL ZCOPY, XERBLA, ZGEMM * .. * .. Intrinsic Functions .. INTRINSIC MAX, DBLE * .. * .. Executable Statements .. * LDWORK = MAX( 1, M ) * * Test if there is enough workspace * IF( LWORK.LT.M*N ) THEN CALL XERBLA( 'ZRRT01', 10 ) RETURN END IF * * Quick return if possible * IF( M.LE.0 .OR. N.LE.0 ) THEN ZRRT01 = ZERO RETURN END IF * NORMA = ZLANGE( 'One-norm', M, N, A, LDA, RDUMMY ) * * Compute WORK := A*P. * DO J = 1, N CALL ZCOPY( M, A( 1, JPVT( J ) ), 1, $ WORK( (J-1)*M+1 ), 1 ) END DO * * Compute WORK := WORK - Q*R. * IF( LSAME( CNJTRN, 'N' ) ) THEN CALL ZGEMM( 'No transpose', 'No transpose', M, N, M, $ -CONE, Q, LDQ, R, LDR, CONE, WORK, LDWORK ) ELSE CALL ZGEMM( 'Conjugate transpose', 'No transpose', $ M, N, M, -CONE, Q, LDQ, R, LDR, CONE, $ WORK, LDWORK ) END IF * * Compute the 1-norm of WORK divided by (max(m,n)*eps). * ZRRT01 = ZLANGE( 'One-norm', M, N, WORK, LDWORK, $ RDUMMY ) / $ ( DBLE( MAX( M, N ) )*DLAMCH( 'Epsilon' ) ) IF( NORMA.NE.ZERO ) $ ZRRT01 = ZRRT01 / NORMA * RETURN * * End of ZRRT01 * END SHAR_EOF fi # end of overwriting check if test -f 'zrrt02.f' then echo shar: will not over-write existing file "'zrrt02.f'" else cat << SHAR_EOF > 'zrrt02.f' DOUBLE PRECISION FUNCTION ZRRT02( M, QT, LDQT, WORK, LWORK ) * * * * .. Scalar Arguments .. INTEGER M, LDQT, LWORK * .. * .. Array Arguments .. COMPLEX*16 QT( LDQT, * ), WORK( LWORK ) * .. * * Purpose * ======= * * ZRRT02 computes the test ratio * * || Q'*Q - I || / (eps * m) * * where the transpose of matrix Q (Q') is stored in array QT. * * * Arguments * ========= * * M (input) INTEGER * Number of rows and columns of matrix QT. * * QT (input) COMPLEX*16 array, dimension (LDQT,N) * Transpose of m by m matrix Q. * * LDQT (input) INTEGER * Leading dimension of array QT. * * WORK (workspace) COMPLEX*16 array, dimension (LWORK) * * LWORK (input) INTEGER * The length of the array WORK. LWORK >= M*M. * * .. Parameters .. DOUBLE PRECISION ZERO, ONE COMPLEX*16 CZERO, CONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, $ CZERO = ( 0.0D+0, 0.0D+0 ), $ CONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER LDWORK * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, ZLANGE EXTERNAL DLAMCH, ZLANGE * .. * .. External Subroutines .. EXTERNAL ZLASET, XERBLA, ZGEMM * .. * .. Intrinsic Functions .. INTRINSIC MAX, DBLE * .. * .. Local Arrays .. DOUBLE PRECISION RDUMMY( 1 ) * .. * .. Executable Statements .. * LDWORK = MAX( 1, M ) * * Test for sufficient workspace. * IF( LWORK.LT.M*M ) THEN CALL XERBLA( 'ZRRT02', 7 ) RETURN END IF * * Quick return if possible. * IF( M.LE.0 ) THEN ZRRT02 = ZERO RETURN END IF * * Set WORK to the identity. * CALL ZLASET( 'All', M, M, CZERO, CONE, WORK, LDWORK ) * * Compute WORK := WORK - QT * QT'. That is, WORK := WORK - Q'*Q. * CALL ZGEMM( 'No transpose', 'Conjugate transpose', $ M, M, M, -CONE, QT, LDQT, QT, LDQT, CONE, $ WORK, LDWORK ) * * Compute || WORK || / ( m * eps ). * ZRRT02 = ZLANGE( 'One-norm', M, M, WORK, LDWORK, $ RDUMMY ) / $ ( DBLE( M )*DLAMCH( 'Epsilon' ) ) * RETURN * * End of ZRRT02 * END SHAR_EOF fi # end of overwriting check cd .. if test -f 'ztest.lg.in' then echo shar: will not over-write existing file "'ztest.lg.in'" else cat << SHAR_EOF > 'ztest.lg.in' Data file for testing COMPLEX LAPACK linear eqn. routines 2 Number of values of M 200 500 Values of M (row dimension) 2 Number of values of N 200 500 Values of N (column dimension) 3 Number of values of NB 1 16 32 Values of NB (the blocksize) 1 0 0 Values of NX (crossover point) 30.0 Threshold value of test ratio T Put T to test the LAPACK routines T Put T to test the error exits ZQP 6 List types on next line if 0 < NTYPES < 6 ZRR 3 List types on next line if 0 < NTYPES < 3 SHAR_EOF fi # end of overwriting check if test -f 'ztest.me.in' then echo shar: will not over-write existing file "'ztest.me.in'" else cat << SHAR_EOF > 'ztest.me.in' Data file for testing COMPLEX LAPACK linear eqn. routines 2 Number of values of M 50 100 Values of M (row dimension) 2 Number of values of N 50 100 Values of N (column dimension) 3 Number of values of NB 1 16 32 Values of NB (the blocksize) 1 0 0 Values of NX (crossover point) 30.0 Threshold value of test ratio T Put T to test the LAPACK routines T Put T to test the error exits ZQP 6 List types on next line if 0 < NTYPES < 6 ZRR 3 List types on next line if 0 < NTYPES < 3 SHAR_EOF fi # end of overwriting check if test -f 'ztest.sm.in' then echo shar: will not over-write existing file "'ztest.sm.in'" else cat << SHAR_EOF > 'ztest.sm.in' Data file for testing COMPLEX LAPACK linear eqn. routines 7 Number of values of M 0 1 2 3 5 10 16 Values of M (row dimension) 7 Number of values of N 0 1 2 3 5 10 16 Values of N (column dimension) 5 Number of values of NB 1 3 3 3 20 Values of NB (the blocksize) 1 0 5 9 1 Values of NX (crossover point) 30.0 Threshold value of test ratio T Put T to test the LAPACK routines T Put T to test the error exits ZQP 6 List types on next line if 0 < NTYPES < 6 ZRR 3 List types on next line if 0 < NTYPES < 3 SHAR_EOF fi # end of overwriting check cd .. if test ! -d 'timing' then mkdir 'timing' fi cd 'timing' if test -f 'ctime.lg.in' then echo shar: will not over-write existing file "'ctime.lg.in'" else cat << SHAR_EOF > 'ctime.lg.in' RRQR timing, COMPLEX square matrices 1 Number of values of M 1000 Values of M (row dimension) 1 Number of values of N 1000 Values of N (column dimension) 1 Number of values of K 0 Values of K 3 Number of values of NB 1 16 32 Values of NB (blocksize) 0 0 0 Values of NX (crossover point) 2 Number of values of LDA 1000 1001 Values of LDA (leading dimension) 0.5 Minimum time in seconds CQR T T F CQP T CRR T SHAR_EOF fi # end of overwriting check if test -f 'ctime.me.in' then echo shar: will not over-write existing file "'ctime.me.in'" else cat << SHAR_EOF > 'ctime.me.in' RRQR timing, COMPLEX square matrices 1 Number of values of M 500 Values of M (row dimension) 1 Number of values of N 500 Values of N (column dimension) 1 Number of values of K 0 Values of K 3 Number of values of NB 1 16 32 Values of NB (blocksize) 0 0 0 Values of NX (crossover point) 2 Number of values of LDA 500 501 Values of LDA (leading dimension) 0.5 Minimum time in seconds CQR T T F CQP T CRR T SHAR_EOF fi # end of overwriting check if test -f 'ctime.sm.in' then echo shar: will not over-write existing file "'ctime.sm.in'" else cat << SHAR_EOF > 'ctime.sm.in' RRQR timing, COMPLEX square matrices 1 Number of values of M 100 Values of M (row dimension) 1 Number of values of N 100 Values of N (column dimension) 1 Number of values of K 0 Values of K 4 Number of values of NB 1 8 16 20 Values of NB (blocksize) 0 0 0 0 Values of NX (crossover point) 2 Number of values of LDA 100 101 Values of LDA (leading dimension) 0.5 Minimum time in seconds CQR T T F CQP T CRR T SHAR_EOF fi # end of overwriting check if test -f 'dtime.lg.in' then echo shar: will not over-write existing file "'dtime.lg.in'" else cat << SHAR_EOF > 'dtime.lg.in' RRQR timing, DOUBLE PRECISION square matrices 1 Number of values of M 1000 Values of M (row dimension) 1 Number of values of N 1000 Values of N (column dimension) 1 Number of values of K 0 Values of K 3 Number of values of NB 1 16 32 Values of NB (blocksize) 0 0 0 Values of NX (crossover point) 2 Number of values of LDA 1000 1001 Values of LDA (leading dimension) 0.5 Minimum time in seconds DQR T T F DQP T DRR T SHAR_EOF fi # end of overwriting check if test -f 'dtime.me.in' then echo shar: will not over-write existing file "'dtime.me.in'" else cat << SHAR_EOF > 'dtime.me.in' RRQR timing, DOUBLE PRECISION square matrices 1 Number of values of M 500 Values of M (row dimension) 1 Number of values of N 500 Values of N (column dimension) 1 Number of values of K 0 Values of K 3 Number of values of NB 1 16 32 Values of NB (blocksize) 0 0 0 Values of NX (crossover point) 2 Number of values of LDA 500 501 Values of LDA (leading dimension) 0.5 Minimum time in seconds DQR T T F DQP T DRR T SHAR_EOF fi # end of overwriting check if test -f 'dtime.sm.in' then echo shar: will not over-write existing file "'dtime.sm.in'" else cat << SHAR_EOF > 'dtime.sm.in' RRQR timing, DOUBLE PRECISION square matrices 1 Number of values of M 100 Values of M (row dimension) 1 Number of values of N 100 Values of N (column dimension) 1 Number of values of K 0 Values of K 4 Number of values of NB 1 8 12 20 Values of NB (blocksize) 0 0 0 0 Values of NX (crossover point) 2 Number of values of LDA 100 101 Values of LDA (leading dimension) 0.5 Minimum time in seconds DQR T T F DQP T DRR T SHAR_EOF fi # end of overwriting check if test -f 'stime.lg.in' then echo shar: will not over-write existing file "'stime.lg.in'" else cat << SHAR_EOF > 'stime.lg.in' RRQR timing, REAL square matrices 1 Number of values of M 1000 Values of M (row dimension) 1 Number of values of N 1000 Values of N (column dimension) 1 Number of values of K 0 Values of K 3 Number of values of NB 1 16 32 Values of NB (blocksize) 0 0 0 Values of NX (crossover point) 2 Number of values of LDA 1000 1001 Values of LDA (leading dimension) 0.5 Minimum time in seconds SQR T T F SQP T SRR T SHAR_EOF fi # end of overwriting check if test -f 'stime.me.in' then echo shar: will not over-write existing file "'stime.me.in'" else cat << SHAR_EOF > 'stime.me.in' RRQR timing, REAL square matrices 1 Number of values of M 500 Values of M (row dimension) 1 Number of values of N 500 Values of N (column dimension) 1 Number of values of K 0 Values of K 3 Number of values of NB 1 16 32 Values of NB (blocksize) 0 0 0 Values of NX (crossover point) 2 Number of values of LDA 500 501 Values of LDA (leading dimension) 0.5 Minimum time in seconds SQR T T F SQP T SRR T SHAR_EOF fi # end of overwriting check if test -f 'stime.sm.in' then echo shar: will not over-write existing file "'stime.sm.in'" else cat << SHAR_EOF > 'stime.sm.in' RRQR timing, REAL square matrices 1 Number of values of M 100 Values of M (row dimension) 1 Number of values of N 100 Values of N (column dimension) 1 Number of values of K 0 Values of K 4 Number of values of NB 1 8 12 20 Values of NB (blocksize) 0 0 0 0 Values of NX (crossover point) 2 Number of values of LDA 100 101 Values of LDA (leading dimension) 0.5 Minimum time in seconds SQR T T F SQP T SRR T SHAR_EOF fi # end of overwriting check if test -f 'timeall' then echo shar: will not over-write existing file "'timeall'" else cat << SHAR_EOF > 'timeall' /bin/rm -f *.out xlintims < stime.sm.in > stime.sm.out xlintimd < dtime.sm.in > dtime.sm.out xlintimc < ctime.sm.in > ctime.sm.out xlintimz < ztime.sm.in > ztime.sm.out xlintims < stime.me.in > stime.me.out xlintimd < dtime.me.in > dtime.me.out xlintimc < ctime.me.in > ctime.me.out xlintimz < ztime.me.in > ztime.me.out xlintims < stime.lg.in > stime.lg.out xlintimd < dtime.lg.in > dtime.lg.out xlintimc < ctime.lg.in > ctime.lg.out xlintimz < ztime.lg.in > ztime.lg.out SHAR_EOF fi # end of overwriting check if test ! -d 'v2' then mkdir 'v2' fi cd 'v2' if test -f 'GenCode' then echo shar: will not over-write existing file "'GenCode'" else cat << SHAR_EOF > 'GenCode' cp ../../../timing/v2/*.f . make source -f Makefile.GenCode SHAR_EOF fi # end of overwriting check 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 -O LOADER = f77 +U77 LOADOPTS = -O LAPACKLIB = /usr/local/lib/lapack/lapack-2.a TMGLIB = /usr/local/lib/lapack/tmglib-2.a BLASLIB = /usr/local/lib/lapack/blas.f77.a # On the SUN Solaris, it is recommended: #FORTRAN = f77 #OPTS = -u -O -dalign #LOADER = f77 #LOADOPTS = -O -dalign #LAPACKLIB = #TMGLIB = /usr/local/lapack/tmglib.a #BLASLIB = /home1/SUNWspro/SC3.0.1/lib/libsunperf.a # On the IBM RS6K, it is recommended: #FORTRAN = xlf #OPTS = -u -O3 #LOADER = xlf #LOADOPTS = -O3 -bnso -bI:/lib/syscalls.exp # #LAPACKLIB = /usr/local/lapack/lib/lapack.a #TMGLIB = /usr/local/lapack/lib/tmglib.a #BLASLIB = -lessl -lblas # ####################################################################### # No more changes are required beyond this line. ####################################################################### # Special modules # RRQRLIB = ../../rrqr.a SHELL = /bin/csh ALINTIM = atimin.o atimck.o icopy.o ilaenv.o xlaenv.o SCINTIM = sprtbl.o sprtb4.o sprtb5.o \ smflop.o sopbl2.o sopbl3.o sopla.o DZINTIM = dprtbl.o dprtb4.o dprtb5.o \ dmflop.o dopbl2.o dopbl3.o dopla.o SLINTIM = stimaa.o stimmg.o \ stimmv.o stimmm.o stimqr.o stimqp.o stimrr.o CLINTIM = ctimaa.o ctimmg.o \ ctimmv.o ctimmm.o ctimqr.o ctimqp.o ctimrr.o DLINTIM = dtimaa.o dtimmg.o \ dtimmv.o dtimmm.o dtimqr.o dtimqp.o dtimrr.o ZLINTIM = ztimaa.o ztimmg.o \ ztimmv.o ztimmm.o ztimqr.o ztimqp.o ztimrr.o all: single double complex complex16 single: ../xlintims double: ../xlintimd complex: ../xlintimc complex16: ../xlintimz ../xlintims : $(ALINTIM) $(SCINTIM) $(SLINTIM) $(LOADER) $(LOADOPTS) $(ALINTIM) $(SCINTIM) $(SLINTIM) \ $(RRQRLIB) $(TMGLIB) $(LAPACKLIB) $(BLASLIB) -o $@ ../xlintimc : $(ALINTIM) $(SCINTIM) $(CLINTIM) $(LOADER) $(LOADOPTS) $(ALINTIM) $(SCINTIM) $(CLINTIM) \ $(RRQRLIB) $(TMGLIB) $(LAPACKLIB) $(BLASLIB) -o $@ ../xlintimd : $(ALINTIM) $(DZINTIM) $(DLINTIM) $(LOADER) $(LOADOPTS) $(ALINTIM) $(DZINTIM) $(DLINTIM) \ $(RRQRLIB) $(TMGLIB) $(LAPACKLIB) $(BLASLIB) -o $@ ../xlintimz : $(ALINTIM) $(DZINTIM) $(ZLINTIM) $(LOADER) $(LOADOPTS) $(ALINTIM) $(DZINTIM) $(ZLINTIM) \ $(RRQRLIB) $(TMGLIB) $(LAPACKLIB) $(BLASLIB) -o $@ $(ALINTIM): $(FRC) $(SCINTIM): $(FRC) $(DZINTIM): $(FRC) $(SLINTIM): $(FRC) $(CLINTIM): $(FRC) $(DLINTIM): $(FRC) $(ZLINTIM): $(FRC) FRC: @FRC=$(FRC) # # Rules for the modules. # .f.o : $(FORTRAN) $(OPTS) -c $*.f # # Clean rule. # clean: - rm -f *.o ../xlintim? 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 timing codes. # CPP = /lib/cpp CPPFLAGS = "" REAL_SOURCES = ../../../v15 GENERATE = $(REAL_SOURCES)/generate TIMING_SOURCES = ../../../timing/v2 # ####################################################################### ####################################################################### # S_TIMING_MODULES = \ stimaa.f stimrr.f D_TIMING_MODULES = \ dtimaa.f dtimrr.f C_TIMING_MODULES = \ ctimaa.f ctimrr.f Z_TIMING_MODULES = \ ztimaa.f ztimrr.f source: single double complex complex16 single: $(S_TIMING_MODULES) double: $(D_TIMING_MODULES) complex: $(C_TIMING_MODULES) complex16: $(Z_TIMING_MODULES) # # Rules for generating timing code. # stimaa.f: $(TIMING_SOURCES)/xtimaa.F $(GENERATE) s $(TIMING_SOURCES)/xtimaa.F stimaa.f $(CPP) $(CPPOPTS) stimrr.f: $(TIMING_SOURCES)/xtimrr.F $(GENERATE) s $(TIMING_SOURCES)/xtimrr.F stimrr.f $(CPP) $(CPPOPTS) dtimaa.f: $(TIMING_SOURCES)/xtimaa.F $(GENERATE) d $(TIMING_SOURCES)/xtimaa.F dtimaa.f $(CPP) $(CPPOPTS) dtimrr.f: $(TIMING_SOURCES)/xtimrr.F $(GENERATE) d $(TIMING_SOURCES)/xtimrr.F dtimrr.f $(CPP) $(CPPOPTS) ctimaa.f: $(TIMING_SOURCES)/ytimaa.F $(GENERATE) c $(TIMING_SOURCES)/ytimaa.F ctimaa.f $(CPP) $(CPPOPTS) ctimrr.f: $(TIMING_SOURCES)/ytimrr.F $(GENERATE) c $(TIMING_SOURCES)/ytimrr.F ctimrr.f $(CPP) $(CPPOPTS) ztimaa.f: $(TIMING_SOURCES)/ytimaa.F $(GENERATE) z $(TIMING_SOURCES)/ytimaa.F ztimaa.f $(CPP) $(CPPOPTS) ztimrr.f: $(TIMING_SOURCES)/ytimrr.F $(GENERATE) z $(TIMING_SOURCES)/ytimrr.F ztimrr.f $(CPP) $(CPPOPTS) # # Clean rule. # clean: - rm -f *.o *.f *.F SHAR_EOF fi # end of overwriting check if test -f 'atimck.f' then echo shar: will not over-write existing file "'atimck.f'" else cat << SHAR_EOF > 'atimck.f' SUBROUTINE ATIMCK( ICHK, SUBNAM, NN, NVAL, NLDA, LDAVAL, NOUT, $ INFO ) * * -- LAPACK timing routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER*6 SUBNAM INTEGER ICHK, INFO, NLDA, NN, NOUT * .. * .. Array Arguments .. INTEGER LDAVAL( * ), NVAL( * ) * .. * * Purpose * ======= * * ATIMCK checks the input values of M, N, or K and LDA to determine * if they are valid for type TYPE. The tests to be performed are * specified in the option variable ICHK. * * On exit, INFO contains a count of the number of pairs (N,LDA) that * were invalid. * * Arguments * ========= * * ICHK (input) INTEGER * Specifies the type of comparison * = 1: M <= LDA * = 2: N <= LDA * = 3: K <= LDA * = 4: N*(N+1)/2 <= LA * = 0 or other value: Determined from name passed in SUBNAM * * SUBNAM (input) CHARACTER*6 * The name of the subroutine or path for which the input * values are to be tested. * * NN (input) INTEGER * The number of values of N contained in the vector NVAL. * * NVAL (input) INTEGER array, dimension( NN ) * The values of the matrix size N. * * NLDA (input) INTEGER * The number of values of LDA contained in the vector LDAVAL. * * LDAVAL (input) INTEGER array, dimension( NLDA ) * The values of the leading dimension of the array A. * * NOUT (input) INTEGER * The unit number for output. * * INFO (output) INTEGER * The number of pairs (N, LDA) that were invalid. * * ===================================================================== * * .. Local Scalars .. CHARACTER*2 TYPE INTEGER I, J, LDA, N * .. * .. External Functions .. LOGICAL LSAMEN EXTERNAL LSAMEN * .. * .. Executable Statements .. * TYPE = SUBNAM( 2: 3 ) INFO = 0 * * M, N, or K must be less than or equal to LDA. * IF( ICHK.EQ.1 .OR. ICHK.EQ.2 .OR. ICHK.EQ.3 ) THEN DO 20 J = 1, NLDA LDA = LDAVAL( J ) DO 10 I = 1, NN IF( NVAL( I ).GT.LDA ) THEN INFO = INFO + 1 IF( NOUT.GT.0 ) THEN IF( ICHK.EQ.1 ) THEN WRITE( NOUT, FMT = 9999 )SUBNAM, NVAL( I ), LDA ELSE IF( ICHK.EQ.2 ) THEN WRITE( NOUT, FMT = 9998 )SUBNAM, NVAL( I ), LDA ELSE WRITE( NOUT, FMT = 9997 )SUBNAM, NVAL( I ), LDA END IF END IF END IF 10 CONTINUE 20 CONTINUE * * IF TYPE = 'PP', 'SP', or 'HP', * then N*(N+1)/2 must be less than or equal to LA = LDAVAL(1). * ELSE IF( ICHK.EQ.4 ) THEN LDA = LDAVAL( 1 ) DO 30 I = 1, NN N = NVAL( I ) IF( N*( N+1 ) / 2.GT.LDA ) THEN INFO = INFO + 1 IF( NOUT.GT.0 ) $ WRITE( NOUT, FMT = 9996 )SUBNAM, N, LDA END IF 30 CONTINUE * * IF TYPE = 'GB', then K must satisfy * 2*K+1 <= LDA, if SUBNAM = 'xGBMV' * 3*K+1 <= LDA, otherwise. * ELSE IF( LSAMEN( 2, TYPE, 'GB' ) ) THEN IF( LSAMEN( 3, SUBNAM( 4: 6 ), 'MV ' ) ) THEN DO 50 J = 1, NLDA LDA = LDAVAL( J ) DO 40 I = 1, NN IF( 2*NVAL( I )+1.GT.LDA ) THEN INFO = INFO + 1 IF( NOUT.GT.0 ) $ WRITE( NOUT, FMT = 9994 )SUBNAM, NVAL( I ), $ LDA, 2*NVAL( I ) + 1 END IF 40 CONTINUE 50 CONTINUE ELSE DO 70 J = 1, NLDA LDA = LDAVAL( J ) DO 60 I = 1, NN IF( 3*NVAL( I )+1.GT.LDA ) THEN INFO = INFO + 1 IF( NOUT.GT.0 ) $ WRITE( NOUT, FMT = 9995 )SUBNAM, NVAL( I ), $ LDA, 3*NVAL( I ) + 1 END IF 60 CONTINUE 70 CONTINUE END IF * * IF TYPE = 'PB' or 'TB', then K must satisfy * K+1 <= LDA. * ELSE IF( LSAMEN( 2, TYPE, 'PB' ) .OR. LSAMEN( 2, TYPE, 'TB' ) ) $ THEN DO 90 J = 1, NLDA LDA = LDAVAL( J ) DO 80 I = 1, NN IF( NVAL( I )+1.GT.LDA ) THEN INFO = INFO + 1 IF( NOUT.GT.0 ) $ WRITE( NOUT, FMT = 9993 )SUBNAM, NVAL( I ), LDA END IF 80 CONTINUE 90 CONTINUE * * IF TYPE = 'SB' or 'HB', then K must satisfy * K+1 <= LDA, if SUBNAM = 'xxxMV ' * ELSE IF( LSAMEN( 2, TYPE, 'SB' ) .OR. LSAMEN( 2, TYPE, 'HB' ) ) $ THEN IF( LSAMEN( 3, SUBNAM( 4: 6 ), 'MV ' ) ) THEN DO 110 J = 1, NLDA LDA = LDAVAL( J ) DO 100 I = 1, NN IF( NVAL( I )+1.GT.LDA ) THEN INFO = INFO + 1 IF( NOUT.GT.0 ) $ WRITE( NOUT, FMT = 9992 )SUBNAM, NVAL( I ), LDA END IF 100 CONTINUE 110 CONTINUE END IF * END IF 9999 FORMAT( ' *** Error for ', A6, ': M > LDA for M =', I6, $ ', LDA =', I7 ) 9998 FORMAT( ' *** Error for ', A6, ': N > LDA for N =', I6, $ ', LDA =', I7 ) 9997 FORMAT( ' *** Error for ', A6, ': K > LDA for K =', I6, $ ', LDA =', I7 ) 9996 FORMAT( ' *** Error for ', A6, ': N*(N+1)/2 > LA for N =', I6, $ ', LA =', I7 ) 9995 FORMAT( ' *** Error for ', A6, ': 3*K+1 > LDA for K =', I6, $ ', LDA =', I7, / ' --> Increase LDA to at least ', I7 ) 9994 FORMAT( ' *** Error for ', A6, ': 2*K+1 > LDA for K =', I6, $ ', LDA =', I7, / ' --> Increase LDA to at least ', I7 ) 9993 FORMAT( ' *** Error for ', A6, ': K+1 > LDA for K =', I6, ', LD', $ 'A =', I7 ) 9992 FORMAT( ' *** Error for ', A6, ': 2*K+2 > LDA for K =', I6, ', ', $ 'LDA =', I7 ) * RETURN * * End of ATIMCK * END SHAR_EOF fi # end of overwriting check if test -f 'atimin.f' then echo shar: will not over-write existing file "'atimin.f'" else cat << SHAR_EOF > 'atimin.f' SUBROUTINE ATIMIN( PATH, LINE, NSUBS, NAMES, TIMSUB, NOUT, INFO ) * * -- LAPACK timing 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*80 LINE CHARACTER*( * ) PATH INTEGER INFO, NOUT, NSUBS * .. * .. Array Arguments .. LOGICAL TIMSUB( * ) CHARACTER*( * ) NAMES( * ) * .. * * Purpose * ======= * * ATIMIN interprets the input line for the timing routines. * The LOGICAL array TIMSUB returns .true. for each routine to be * timed and .false. for the routines which are not to be timed. * * Arguments * ========= * * PATH (input) CHARACTER*(*) * The LAPACK path name of the calling routine. The path name * may be at most 6 characters long. If LINE(1:LEN(PATH)) is * the same as PATH, then the input line is searched for NSUBS * non-blank characters, otherwise, the input line is assumed to * specify a single subroutine name. * * LINE (input) CHARACTER*80 * The input line to be evaluated. The path or subroutine name * must begin in column 1 and the part of the line after the * name is used to indicate the routines to be timed. * See below for further details. * * NSUBS (input) INTEGER * The number of subroutines in the LAPACK path name of the * calling routine. * * NAMES (input) CHARACTER*(*) array, dimension (NSUBS) * The names of the subroutines in the LAPACK path name of the * calling routine. * * TIMSUB (output) LOGICAL array, dimension (NSUBS) * For each I from 1 to NSUBS, TIMSUB( I ) is set to .true. if * the subroutine NAMES( I ) is to be timed; otherwise, * TIMSUB( I ) is set to .false. * * NOUT (input) INTEGER * The unit number on which error messages will be printed. * * INFO (output) INTEGER * The return status of this routine. * = -1: Unrecognized path or subroutine name * = 0: Normal return * = 1: Name was recognized, but no timing requested * * Further Details * ======= ======= * * An input line begins with a subroutine or path name, optionally * followed by one or more non-blank characters indicating the specific * routines to be timed. * * If the character string in PATH appears at the beginning of LINE, * up to NSUBS routines may be timed. If LINE is blank after the path * name, all the routines in the path will be timed. If LINE is not * blank after the path name, the rest of the line is searched * for NSUBS nonblank characters, and if the i-th such character is * 't' or 'T', then the i-th subroutine in this path will be timed. * For example, the input line * SGE T T T T * requests timing of the first 4 subroutines in the SGE path. * * If the character string in PATH does not appear at the beginning of * LINE, then LINE is assumed to begin with a subroutine name. The name * is assumed to end in column 6 or in column i if column i+1 is blank * and i+1 <= 6. If LINE is completely blank after the subroutine name, * the routine will be timed. If LINE is not blank after the subroutine * name, then the subroutine will be timed if the first non-blank after * the name is 't' or 'T'. * * ===================================================================== * * .. Local Scalars .. LOGICAL REQ CHARACTER*6 CNAME INTEGER I, ISTART, ISTOP, ISUB, LCNAME, LNAMES, LPATH * .. * .. External Functions .. LOGICAL LSAME, LSAMEN EXTERNAL LSAME, LSAMEN * .. * .. Intrinsic Functions .. INTRINSIC LEN, MIN * .. * .. Executable Statements .. * * * Initialize * INFO = 0 LCNAME = 1 DO 10 I = 2, 6 IF( LINE( I: I ).EQ.' ' ) $ GO TO 20 LCNAME = I 10 CONTINUE 20 CONTINUE LPATH = MIN( LCNAME+1, LEN( PATH ) ) LNAMES = MIN( LCNAME+1, LEN( NAMES( 1 ) ) ) CNAME = LINE( 1: LCNAME ) * DO 30 I = 1, NSUBS TIMSUB( I ) = .FALSE. 30 CONTINUE ISTOP = 0 * * Check for a valid path or subroutine name. * IF( LCNAME.LE.LEN( PATH ) .AND. LSAMEN( LPATH, CNAME, PATH ) ) $ THEN ISTART = 1 ISTOP = NSUBS ELSE IF( LCNAME.LE.LEN( NAMES( 1 ) ) ) THEN DO 40 I = 1, NSUBS IF( LSAMEN( LNAMES, CNAME, NAMES( I ) ) ) THEN ISTART = I ISTOP = I END IF 40 CONTINUE END IF * IF( ISTOP.EQ.0 ) THEN WRITE( NOUT, FMT = 9999 )CNAME 9999 FORMAT( 1X, A, ': Unrecognized path or subroutine name', / ) INFO = -1 GO TO 110 END IF * * Search the rest of the input line for 1 or NSUBS nonblank * characters, where 'T' or 't' means 'Time this routine'. * ISUB = ISTART DO 50 I = LCNAME + 1, 80 IF( LINE( I: I ).NE.' ' ) THEN TIMSUB( ISUB ) = LSAME( LINE( I: I ), 'T' ) ISUB = ISUB + 1 IF( ISUB.GT.ISTOP ) $ GO TO 60 END IF 50 CONTINUE 60 CONTINUE * * If no characters appear after the routine or path name, then * time the routine or all the routines in the path. * IF( ISUB.EQ.ISTART ) THEN DO 70 I = ISTART, ISTOP TIMSUB( I ) = .TRUE. 70 CONTINUE ELSE * * Test to see if any timing was requested. * REQ = .FALSE. DO 80 I = ISTART, ISUB - 1 REQ = REQ .OR. TIMSUB( I ) 80 CONTINUE IF( .NOT.REQ ) THEN WRITE( NOUT, FMT = 9998 )CNAME 9998 FORMAT( 1X, A, ' was not timed', / ) INFO = 1 GO TO 110 END IF * * If fewer than NSUBS characters are specified for a path name, * the rest are assumed to be 'F'. * DO 100 I = ISUB, ISTOP TIMSUB( I ) = .FALSE. 100 CONTINUE END IF 110 CONTINUE RETURN * * End of ATIMIN * END SHAR_EOF fi # end of overwriting check if test -f 'ctimaa.f' then echo shar: will not over-write existing file "'ctimaa.f'" else cat << SHAR_EOF > 'ctimaa.f' PROGRAM CTIMAA * * -- LAPACK timing routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * Rewritten to include the timing of rrqr code. * * Purpose * ======= * * An annotated example of a data file can be obtained by deleting the * first 3 characters from the following lines: * LAPACK timing, COMPLEX square matrices * 5 Number of values of M * 100 200 300 400 500 Values of M (row dimension) * 5 Number of values of N * 100 200 300 400 500 Values of N (column dimension) * 2 Number of values of K * 100 400 Values of K * 5 Number of values of NB * 1 16 32 48 64 Values of NB (blocksize) * 0 48 128 128 128 Values of NX (crossover point) * 2 Number of values of LDA * 512 513 Values of LDA (leading dimension) * 0.0 Minimum time in seconds * CQR T T F * CQP T * CRR T * * The routines are timed for all combinations of applicable values of * M, N, K, NB, NX, and LDA, and for all combinations of options such as * UPLO and TRANS. For Level 2 BLAS timings, values of NB are used for * INCX. Certain subroutines, such as the QR factorization, treat the * values of M and N as ordered pairs and operate on M x N matrices. * * Internal Parameters * =================== * * NMAX INTEGER * The maximum value of M or N for square matrices. * * LDAMAX INTEGER * The maximum value of LDA. * * NMAXB INTEGER * The maximum value of N for band matrices. * * MAXVAL INTEGER * The maximum number of values that can be read in for M, N, * K, NB, or NX. * * MXNLDA INTEGER * The maximum number of values that can be read in for LDA. * * NIN INTEGER * The unit number for input. Currently set to 5 (std input). * * NOUT INTEGER * The unit number for output. Currently set to 6 (std output). * * ===================================================================== * * .. Parameters .. INTEGER NMAX, LDAMAX, NMAXB PARAMETER ( NMAX = 1001, LDAMAX = NMAX+4, NMAXB = 5000 ) INTEGER LA PARAMETER ( LA = NMAX*LDAMAX ) INTEGER MAXVAL, MXNLDA PARAMETER ( MAXVAL = 12, MXNLDA = 4 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) * .. * .. Local Scalars .. LOGICAL BLAS, LDAMOK, LDANOK, LDAOK, MOK, NOK, NXNBOK CHARACTER C1 CHARACTER*2 C2 CHARACTER*3 C3 CHARACTER*80 LINE INTEGER I, L, LDR1, LDR2, LDR3, MAXK, MAXLDA, $ MAXM, MAXN, MAXNB, MKMAX, NEED, NK, NLDA, NM, $ NN, NNB REAL S1, S2, TIMMIN * .. * .. Local Arrays .. INTEGER IWORK( 2*NMAXB ), KVAL( MAXVAL ), $ LDAVAL( MXNLDA ), MVAL( MAXVAL ), $ NBVAL( MAXVAL ), NVAL( MAXVAL ), $ NXVAL( MAXVAL ) REAL D( 2*NMAX ), $ RESLTS( MAXVAL, MAXVAL, 2*MXNLDA, 4*MAXVAL ) COMPLEX A( LA, 4 ), E( 2*NMAX ) * .. * .. External Functions .. LOGICAL LSAME, LSAMEN REAL SECOND EXTERNAL LSAME, LSAMEN, SECOND * .. * .. External Subroutines .. EXTERNAL CTIMMM, CTIMMV, $ CTIMQP, CTIMQR, CTIMRR * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Arrays in Common .. INTEGER IPARMS( 100 ) * .. * .. Common blocks .. COMMON / CLAENV / IPARMS * .. * .. Executable Statements .. * S1 = SECOND( ) LDR1 = MAXVAL LDR2 = MAXVAL LDR3 = 2*MXNLDA * * Read the first line. The first four characters must be 'BLAS' * for the BLAS data file format to be used. Otherwise, the LAPACK * data file format is assumed. * READ( NIN, FMT = '( A80 )' )LINE BLAS = LSAMEN( 4, LINE, 'BLAS' ) * * Find the last non-blank and print the first line of input as the * first line of output. * DO 10 L = 80, 1, -1 IF( LINE( L: L ).NE.' ' ) $ GO TO 20 10 CONTINUE L = 1 20 CONTINUE WRITE( NOUT, FMT = '( 1X, A, / )' )LINE( 1: L ) * * Read in NM and the values for M. * READ( NIN, FMT = * )NM IF( NM.GT.MAXVAL ) THEN WRITE( NOUT, FMT = 9999 )'M', 'NM', MAXVAL NM = MAXVAL END IF READ( NIN, FMT = * )( MVAL( I ), I = 1, NM ) WRITE( NOUT, FMT = 9991 )'M: ', ( MVAL( I ), I = 1, NM ) * * Check that M <= NMAXB for all values of M. * MOK = .TRUE. MAXM = 0 DO 30 I = 1, NM MAXM = MAX( MVAL( I ), MAXM ) IF( MVAL( I ).GT.NMAXB ) THEN WRITE( NOUT, FMT = 9997 )'M', MVAL( I ), NMAXB MOK = .FALSE. END IF 30 CONTINUE IF( .NOT.MOK ) $ WRITE( NOUT, FMT = * ) * * Read in NN and the values for N. * READ( NIN, FMT = * )NN IF( NN.GT.MAXVAL ) THEN WRITE( NOUT, FMT = 9999 )'N', 'NN', MAXVAL NN = MAXVAL END IF READ( NIN, FMT = * )( NVAL( I ), I = 1, NN ) WRITE( NOUT, FMT = 9991 )'N: ', ( NVAL( I ), I = 1, NN ) * * Check that N <= NMAXB for all values of N. * NOK = .TRUE. MAXN = 0 DO 40 I = 1, NN MAXN = MAX( NVAL( I ), MAXN ) IF( NVAL( I ).GT.NMAXB ) THEN WRITE( NOUT, FMT = 9997 )'N', NVAL( I ), NMAXB NOK = .FALSE. END IF 40 CONTINUE IF( .NOT.NOK ) $ WRITE( NOUT, FMT = * ) * * Read in NK and the values for K. * READ( NIN, FMT = * )NK IF( NK.GT.MAXVAL ) THEN WRITE( NOUT, FMT = 9999 )'K', 'NK', MAXVAL NK = MAXVAL END IF READ( NIN, FMT = * )( KVAL( I ), I = 1, NK ) WRITE( NOUT, FMT = 9991 )'K: ', ( KVAL( I ), I = 1, NK ) * * Find the maximum value of K (= NRHS). * MAXK = 0 DO 50 I = 1, NK MAXK = MAX( KVAL( I ), MAXK ) 50 CONTINUE MKMAX = MAXM*MAX( 2, MAXK ) * * Read in NNB and the values for NB. For the BLAS input files, * NBVAL is used to store values for INCX and INCY. * READ( NIN, FMT = * )NNB IF( NNB.GT.MAXVAL ) THEN WRITE( NOUT, FMT = 9999 )'NB', 'NNB', MAXVAL NNB = MAXVAL END IF READ( NIN, FMT = * )( NBVAL( I ), I = 1, NNB ) * * Find the maximum value of NB. * MAXNB = 0 DO 60 I = 1, NNB MAXNB = MAX( NBVAL( I ), MAXNB ) 60 CONTINUE * IF( BLAS ) THEN WRITE( NOUT, FMT = 9991 )'INCX: ', ( NBVAL( I ), I = 1, NNB ) DO 70 I = 1, NNB NXVAL( I ) = 0 70 CONTINUE ELSE * * LAPACK data files: Read in the values for NX. * READ( NIN, FMT = * )( NXVAL( I ), I = 1, NNB ) * WRITE( NOUT, FMT = 9991 )'NB: ', ( NBVAL( I ), I = 1, NNB ) WRITE( NOUT, FMT = 9991 )'NX: ', ( NXVAL( I ), I = 1, NNB ) END IF * * Read in NLDA and the values for LDA. * READ( NIN, FMT = * )NLDA IF( NLDA.GT.MXNLDA ) THEN WRITE( NOUT, FMT = 9999 )'LDA', 'NLDA', MXNLDA NLDA = MXNLDA END IF READ( NIN, FMT = * )( LDAVAL( I ), I = 1, NLDA ) WRITE( NOUT, FMT = 9991 )'LDA: ', ( LDAVAL( I ), I = 1, NLDA ) * * Check that LDA >= 1 for all values of LDA. * LDAOK = .TRUE. MAXLDA = 0 DO 80 I = 1, NLDA MAXLDA = MAX( LDAVAL( I ), MAXLDA ) IF( LDAVAL( I ).LE.0 ) THEN WRITE( NOUT, FMT = 9998 )LDAVAL( I ) LDAOK = .FALSE. END IF 80 CONTINUE IF( .NOT.LDAOK ) $ WRITE( NOUT, FMT = * ) * * Check that MAXLDA*MAXN <= LA (for the dense routines). * LDANOK = .TRUE. NEED = MAXLDA*MAXN IF( NEED.GT.LA ) THEN WRITE( NOUT, FMT = 9995 )MAXLDA, MAXN, NEED LDANOK = .FALSE. END IF * * Check that MAXLDA*MAXM + MAXM*MAXK <= 3*LA (for band routines). * LDAMOK = .TRUE. NEED = MAXLDA*MAXM + MAXM*MAXK IF( NEED.GT.3*LA ) THEN NEED = ( NEED+2 ) / 3 WRITE( NOUT, FMT = 9994 )MAXLDA, MAXM, MAXK, NEED LDAMOK = .FALSE. END IF * * Check that MAXN*MAXNB (or MAXN*INCX) <= LA. * NXNBOK = .TRUE. NEED = MAXN*MAXNB IF( NEED.GT.LA ) THEN WRITE( NOUT, FMT = 9996 )MAXN, MAXNB, NEED NXNBOK = .FALSE. END IF * IF( .NOT.( MOK .AND. NOK .AND. LDAOK .AND. LDANOK .AND. NXNBOK ) ) $ THEN WRITE( NOUT, FMT = 9984 ) GO TO 110 END IF IF( .NOT.LDAMOK ) $ WRITE( NOUT, FMT = * ) * * Read the minimum time to time a subroutine. * WRITE( NOUT, FMT = * ) READ( NIN, FMT = * )TIMMIN WRITE( NOUT, FMT = 9993 )TIMMIN WRITE( NOUT, FMT = * ) * * Read the first input line. * READ( NIN, FMT = '(A)', END = 100 )LINE * * If the first record is the special signal 'NONE', then get the * next line but don't time CGEMV and CGEMM. * IF( LSAMEN( 4, LINE, 'NONE' ) ) THEN READ( NIN, FMT = '(A)', END = 100 )LINE ELSE WRITE( NOUT, FMT = 9990 ) * * Time CGEMV and CGEMM. * CALL CTIMMV( 'CGEMV ', NN, NVAL, NNB, NBVAL, NLDA, $ LDAVAL, TIMMIN, A( 1, 1 ), LA, A( 1, 2 ), $ A( 1, 3 ), RESLTS, LDR1, LDR2, NOUT ) CALL CTIMMM( 'CGEMM ', 'N', NN, NVAL, NLDA, LDAVAL, $ TIMMIN, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), RESLTS, $ LDR1, LDR2, NOUT ) END IF * * Call the appropriate timing routine for each input line. * WRITE( NOUT, FMT = 9988 ) 90 CONTINUE C1 = LINE( 1: 1 ) C2 = LINE( 2: 3 ) C3 = LINE( 4: 6 ) * * Check first character for correct precision. * IF( .NOT.LSAME( C1, 'Cprecision' ) ) THEN WRITE( NOUT, FMT = 9987 )LINE( 1: 6 ) * ELSE IF( LSAMEN( 2, C2, 'QR' ) .OR. LSAMEN( 2, C3, 'QR' ) .OR. $ LSAMEN( 2, C3( 2: 3 ), 'QR' ) ) THEN * * QR routines * CALL CTIMQR( LINE, NN, MVAL, NVAL, NK, KVAL, NNB, NBVAL, $ NXVAL, NLDA, LDAVAL, TIMMIN, A( 1, 1 ), E, $ A( 1, 2 ), A( 1, 3 ), D, RESLTS, LDR1, LDR2, $ LDR3, NOUT ) * ELSE IF( LSAMEN( 2, C2, 'QP' ) .OR. LSAMEN( 3, C3, 'QPF' ) ) THEN * * QR with column pivoting * CALL CTIMQP( LINE, NM, MVAL, NVAL, NLDA, LDAVAL, TIMMIN, $ A( 1, 1 ), A( 1, 2 ), E, A( 1, 3 ), D, IWORK, $ RESLTS, LDR1, LDR2, NOUT ) * ELSE IF( LSAMEN( 2, C2, 'RR' ) .OR. LSAMEN( 3, C3, 'RRF' ) ) THEN * * Rank-Revealing QR factorization * CALL CTIMRR( LINE, NM, MVAL, NVAL, NK, KVAL, $ NNB, NBVAL, NXVAL, NLDA, LDAVAL, TIMMIN, $ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), $ A( 1, 4 ), D, IWORK, $ RESLTS, LDR1, LDR2, NOUT ) * ELSE * WRITE( NOUT, FMT = 9987 )LINE( 1: 6 ) END IF * * Read the next line of the input file. * READ( NIN, FMT = '(A)', END = 100 )LINE GO TO 90 * * Branch to this line when the last record is read. * 100 CONTINUE S2 = SECOND( ) WRITE( NOUT, FMT = 9986 ) WRITE( NOUT, FMT = 9985 )S2 - S1 110 CONTINUE * 9999 FORMAT( ' Too many values of ', A, ' using ', A, ' = ', I2 ) 9998 FORMAT( ' *** LDA = ', I7, ' is too small, must have ', $ 'LDA > 0.' ) 9997 FORMAT( ' *** ', A1, ' = ', I7, ' is too big: ', $ 'maximum allowed is', I7 ) 9996 FORMAT( ' *** N*NB is too big for N =', I6, ', NB =', I6, $ / ' --> Increase LA to at least ', I8 ) 9995 FORMAT( ' *** LDA*N is too big for the dense routines ', '(LDA =', $ I6, ', N =', I6, ')', / ' --> Increase LA to at least ', $ I8 ) 9994 FORMAT( ' *** (LDA+K)*M is too big for the band routines ', $ '(LDA=', I6, ', M=', I6, ', K=', I6, ')', $ / ' --> Increase LA to at least ', I8 ) 9993 FORMAT( ' The minimum time a subroutine will be timed = ', F6.3, $ ' seconds' ) 9991 FORMAT( 4X, A7, 1X, 10I6, / 12X, 10I6 ) 9990 FORMAT( / ' ------------------------------', $ / ' >>>>> Sample BLAS <<<<<', $ / ' ------------------------------' ) 9988 FORMAT( / ' ------------------------------', $ / ' >>>>> Timing data <<<<<', $ / ' ------------------------------' ) 9987 FORMAT( 1X, A6, ': Unrecognized path or subroutine name', / ) 9986 FORMAT( ' End of tests' ) 9985 FORMAT( ' Total time used = ', F12.2, ' seconds' ) 9984 FORMAT( / ' Tests not done due to input errors' ) * * End of CTIMAA * END SHAR_EOF fi # end of overwriting check if test -f 'ctimmg.f' then echo shar: will not over-write existing file "'ctimmg.f'" else cat << SHAR_EOF > 'ctimmg.f' SUBROUTINE CTIMMG( IFLAG, M, N, A, LDA, KL, KU ) * * -- LAPACK timing 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 IFLAG, KL, KU, LDA, M, N * .. * .. Array Arguments .. COMPLEX A( LDA, * ) * .. * * Purpose * ======= * * CTIMMG generates a complex test matrix whose type is given by IFLAG. * All the matrices are Toeplitz (constant along a diagonal), with * random elements on each diagonal. * * Arguments * ========= * * IFLAG (input) INTEGER * The type of matrix to be generated. * = 0 or 1: General matrix * = 2 or -2: General banded matrix * = 3 or -3: Hermitian positive definite matrix * = 4 or -4: Hermitian positive definite packed * = 5 or -5: Hermitian positive definite banded * = 6 or -6: Hermitian indefinite matrix * = 7 or -7: Hermitian indefinite packed * = 8 or -8: Symmetric indefinite matrix * = 9 or -9: Symmetric indefinite packed * = 10 or -10: Symmetric indefinite banded * = 11 or -11: Triangular matrix * = 12 or -12: Triangular packed * = 13 or -13: Triangular banded * = 14: General tridiagonal * For Hermitian, symmetric, or triangular matrices, IFLAG > 0 * indicates upper triangular storage and IFLAG < 0 indicates * lower triangular storage. * * M (input) INTEGER * The number of rows of the matrix to be generated. * * N (input) INTEGER * The number of columns of the matrix to be generated. * * A (output) COMPLEX array, dimension (LDA,N) * The generated matrix. * * If the absolute value of IFLAG is 1, 3, 6, or 8, the leading * M x N (or N x N) subblock is used to store the matrix. * If the matrix is symmetric, only the upper or lower triangle * of this block is referenced. * * If the absolute value of IFLAG is 4, 7, or 9, the matrix is * Hermitian or symmetric and packed storage is used for the * upper or lower triangle. The triangular matrix is stored * columnwise as a linear array, and the array A is treated as a * vector of length LDA. LDA must be set to at least N*(N+1)/2. * * If the absolute value of IFLAG is 2 or 5, the matrix is * returned in band format. The columns of the matrix are * specified in the columns of A and the diagonals of the * matrix are specified in the rows of A, with the leading * diagonal in row * KL + KU + 1, if IFLAG = 2 * KU + 1, if IFLAG = 5 or -2 * 1, if IFLAG = -5 * If IFLAG = 2, the first KL rows are not used to leave room * for pivoting in CGBTRF. * * LDA (input) INTEGER * The leading dimension of A. If the generated matrix is * packed, LDA >= N*(N+1)/2, otherwise LDA >= max(1,M). * * KL (input) INTEGER * The number of subdiagonals if IFLAG = 2, 5, or -5. * * KU (input) INTEGER * The number of superdiagonals if IFLAG = 2, 5, or -5. * * ===================================================================== * * .. Local Scalars .. INTEGER I, J, JJ, JN, K, MJ, MU * .. * .. Local Arrays .. INTEGER ISEED( 4 ) * .. * .. Intrinsic Functions .. INTRINSIC MIN, REAL * .. * .. External Functions .. COMPLEX CLARND EXTERNAL CLARND * .. * .. External Subroutines .. EXTERNAL CCOPY, CLARNV * .. * .. Data statements .. DATA ISEED / 0, 0, 0, 1 / * .. * .. Executable Statements .. * IF( M.LE.0 .OR. N.LE.0 ) THEN RETURN * ELSE IF( IFLAG.EQ.0 .OR. IFLAG.EQ.1 ) THEN * * General matrix * * Set first column and row to random values. * CALL CLARNV( 2, ISEED, M, A( 1, 1 ) ) DO 10 J = 2, N, M MJ = MIN( M, N-J+1 ) CALL CLARNV( 2, ISEED, MJ, A( 1, J ) ) IF( MJ.GT.1 ) $ CALL CCOPY( MJ-1, A( 2, J ), 1, A( 1, J+1 ), LDA ) 10 CONTINUE * * Fill in the rest of the matrix. * DO 30 J = 2, N DO 20 I = 2, M A( I, J ) = A( I-1, J-1 ) 20 CONTINUE 30 CONTINUE * ELSE IF( IFLAG.EQ.2 .OR. IFLAG.EQ.-2 ) THEN * * General band matrix * IF( IFLAG.EQ.2 ) THEN K = KL + KU + 1 ELSE K = KU + 1 END IF CALL CLARNV( 2, ISEED, MIN( M, KL+1 ), A( K, 1 ) ) MU = MIN( N-1, KU ) CALL CLARNV( 2, ISEED, MU+1, A( K-MU, N ) ) DO 40 J = 2, N - 1 MU = MIN( J-1, KU ) CALL CCOPY( MU, A( K-MU, N ), 1, A( K-MU, J ), 1 ) CALL CCOPY( MIN( M-J+1, KL+1 ), A( K, 1 ), 1, A( K, J ), 1 ) 40 CONTINUE * ELSE IF( IFLAG.EQ.3 ) THEN * * Hermitian positive definite, upper triangle * CALL CLARNV( 2, ISEED, N-1, A( 1, N ) ) A( N, N ) = REAL( N ) DO 50 J = N - 1, 1, -1 CALL CCOPY( J, A( N-J+1, N ), 1, A( 1, J ), 1 ) 50 CONTINUE * ELSE IF( IFLAG.EQ.-3 ) THEN * * Hermitian positive definite, lower triangle * A( 1, 1 ) = REAL( N ) IF( N.GT.1 ) $ CALL CLARNV( 2, ISEED, N-1, A( 2, 1 ) ) DO 60 J = 2, N CALL CCOPY( N-J+1, A( 1, 1 ), 1, A( J, J ), 1 ) 60 CONTINUE * ELSE IF( IFLAG.EQ.4 ) THEN * * Hermitian positive definite packed, upper triangle * JN = ( N-1 )*N / 2 + 1 CALL CLARNV( 2, ISEED, N-1, A( JN, 1 ) ) A( JN+N-1, 1 ) = REAL( N ) JJ = JN DO 70 J = N - 1, 1, -1 JJ = JJ - J JN = JN + 1 CALL CCOPY( J, A( JN, 1 ), 1, A( JJ, 1 ), 1 ) 70 CONTINUE * ELSE IF( IFLAG.EQ.-4 ) THEN * * Hermitian positive definite packed, lower triangle * A( 1, 1 ) = REAL( N ) IF( N.GT.1 ) $ CALL CLARNV( 2, ISEED, N-1, A( 2, 1 ) ) JJ = N + 1 DO 80 J = 2, N CALL CCOPY( N-J+1, A( 1, 1 ), 1, A( JJ, 1 ), 1 ) JJ = JJ + N - J + 1 80 CONTINUE * ELSE IF( IFLAG.EQ.5 ) THEN * * Hermitian positive definite banded, upper triangle * K = KL MU = MIN( N-1, K ) CALL CLARNV( 2, ISEED, MU, A( K+1-MU, N ) ) A( K+1, N ) = REAL( N ) DO 90 J = N - 1, 1, -1 MU = MIN( J, K+1 ) CALL CCOPY( MU, A( K+2-MU, N ), 1, A( K+2-MU, J ), 1 ) 90 CONTINUE * ELSE IF( IFLAG.EQ.-5 ) THEN * * Hermitian positive definite banded, lower triangle * K = KL A( 1, 1 ) = REAL( N ) CALL CLARNV( 2, ISEED, MIN( N-1, K ), A( 2, 1 ) ) DO 100 J = 2, N CALL CCOPY( MIN( N-J+1, K+1 ), A( 1, 1 ), 1, A( 1, J ), 1 ) 100 CONTINUE * ELSE IF( IFLAG.EQ.6 ) THEN * * Hermitian indefinite, upper triangle * CALL CLARNV( 2, ISEED, N, A( 1, N ) ) A( N, N ) = REAL( A( N, N ) ) DO 110 J = N - 1, 1, -1 CALL CCOPY( J, A( N-J+1, N ), 1, A( 1, J ), 1 ) 110 CONTINUE * ELSE IF( IFLAG.EQ.-6 ) THEN * * Hermitian indefinite, lower triangle * CALL CLARNV( 2, ISEED, N, A( 1, 1 ) ) A( 1, 1 ) = REAL( A( 1, 1 ) ) DO 120 J = 2, N CALL CCOPY( N-J+1, A( 1, 1 ), 1, A( J, J ), 1 ) 120 CONTINUE * ELSE IF( IFLAG.EQ.7 ) THEN * * Hermitian indefinite packed, upper triangle * JN = ( N-1 )*N / 2 + 1 CALL CLARNV( 2, ISEED, N, A( JN, 1 ) ) A( JN+N-1, 1 ) = REAL( A( JN+N-1, 1 ) ) JJ = JN DO 130 J = N - 1, 1, -1 JJ = JJ - J JN = JN + 1 CALL CCOPY( J, A( JN, 1 ), 1, A( JJ, 1 ), 1 ) 130 CONTINUE * ELSE IF( IFLAG.EQ.-7 ) THEN * * Hermitian indefinite packed, lower triangle * CALL CLARNV( 2, ISEED, N, A( 1, 1 ) ) A( 1, 1 ) = REAL( A( 1, 1 ) ) JJ = N + 1 DO 140 J = 2, N CALL CCOPY( N-J+1, A( 1, 1 ), 1, A( JJ, 1 ), 1 ) JJ = JJ + N - J + 1 140 CONTINUE * ELSE IF( IFLAG.EQ.8 ) THEN * * Symmetric indefinite, upper triangle * CALL CLARNV( 2, ISEED, N, A( 1, N ) ) DO 150 J = N - 1, 1, -1 CALL CCOPY( J, A( N-J+1, N ), 1, A( 1, J ), 1 ) 150 CONTINUE * ELSE IF( IFLAG.EQ.-8 ) THEN * * Symmetric indefinite, lower triangle * CALL CLARNV( 2, ISEED, N, A( 1, 1 ) ) DO 160 J = 2, N CALL CCOPY( N-J+1, A( 1, 1 ), 1, A( J, J ), 1 ) 160 CONTINUE * ELSE IF( IFLAG.EQ.9 ) THEN * * Symmetric indefinite packed, upper triangle * JN = ( N-1 )*N / 2 + 1 CALL CLARNV( 2, ISEED, N, A( JN, 1 ) ) JJ = JN DO 170 J = N - 1, 1, -1 JJ = JJ - J JN = JN + 1 CALL CCOPY( J, A( JN, 1 ), 1, A( JJ, 1 ), 1 ) 170 CONTINUE * ELSE IF( IFLAG.EQ.-9 ) THEN * * Symmetric indefinite packed, lower triangle * CALL CLARNV( 2, ISEED, N, A( 1, 1 ) ) JJ = N + 1 DO 180 J = 2, N CALL CCOPY( N-J+1, A( 1, 1 ), 1, A( JJ, 1 ), 1 ) JJ = JJ + N - J + 1 180 CONTINUE * ELSE IF( IFLAG.EQ.10 ) THEN * * Symmetric indefinite banded, upper triangle * K = KL MU = MIN( N, K+1 ) CALL CLARNV( 2, ISEED, MU, A( K+2-MU, N ) ) DO 190 J = N - 1, 1, -1 MU = MIN( J, K+1 ) CALL CCOPY( MU, A( K+2-MU, N ), 1, A( K+2-MU, J ), 1 ) 190 CONTINUE * ELSE IF( IFLAG.EQ.-10 ) THEN * * Symmetric indefinite banded, lower triangle * K = KL CALL CLARNV( 2, ISEED, MIN( N, K+1 ), A( 1, 1 ) ) DO 200 J = 2, N CALL CCOPY( MIN( N-J+1, K+1 ), A( 1, 1 ), 1, A( 1, J ), 1 ) 200 CONTINUE * ELSE IF( IFLAG.EQ.11 ) THEN * * Upper triangular * CALL CLARNV( 2, ISEED, N-1, A( 1, N ) ) A( N, N ) = REAL( N )*CLARND( 5, ISEED ) DO 210 J = N - 1, 1, -1 CALL CCOPY( J, A( N-J+1, N ), 1, A( 1, J ), 1 ) 210 CONTINUE * ELSE IF( IFLAG.EQ.-11 ) THEN * * Lower triangular * A( 1, 1 ) = REAL( N )*CLARND( 5, ISEED ) IF( N.GT.1 ) $ CALL CLARNV( 2, ISEED, N-1, A( 2, 1 ) ) DO 220 J = 2, N CALL CCOPY( N-J+1, A( 1, 1 ), 1, A( J, J ), 1 ) 220 CONTINUE * ELSE IF( IFLAG.EQ.12 ) THEN * * Upper triangular packed * JN = ( N-1 )*N / 2 + 1 CALL CLARNV( 2, ISEED, N-1, A( JN, 1 ) ) A( JN+N-1, 1 ) = REAL( N )*CLARND( 5, ISEED ) JJ = JN DO 230 J = N - 1, 1, -1 JJ = JJ - J JN = JN + 1 CALL CCOPY( J, A( JN, 1 ), 1, A( JJ, 1 ), 1 ) 230 CONTINUE * ELSE IF( IFLAG.EQ.-12 ) THEN * * Lower triangular packed * A( 1, 1 ) = REAL( N )*CLARND( 5, ISEED ) IF( N.GT.1 ) $ CALL CLARNV( 2, ISEED, N-1, A( 2, 1 ) ) JJ = N + 1 DO 240 J = 2, N CALL CCOPY( N-J+1, A( 1, 1 ), 1, A( JJ, 1 ), 1 ) JJ = JJ + N - J + 1 240 CONTINUE * ELSE IF( IFLAG.EQ.13 ) THEN * * Upper triangular banded * K = KL MU = MIN( N-1, K ) CALL CLARNV( 2, ISEED, MU, A( K+1-MU, N ) ) A( K+1, N ) = REAL( K+1 )*CLARND( 5, ISEED ) DO 250 J = N - 1, 1, -1 MU = MIN( J, K+1 ) CALL CCOPY( MU, A( K+2-MU, N ), 1, A( K+2-MU, J ), 1 ) 250 CONTINUE * ELSE IF( IFLAG.EQ.-13 ) THEN * * Lower triangular banded * K = KL A( 1, 1 ) = REAL( K+1 )*CLARND( 5, ISEED ) IF( N.GT.1 ) $ CALL CLARNV( 2, ISEED, MIN( N-1, K ), A( 2, 1 ) ) DO 260 J = 2, N CALL CCOPY( MIN( N-J+1, K+1 ), A( 1, 1 ), 1, A( 1, J ), 1 ) 260 CONTINUE * ELSE IF( IFLAG.EQ.14 ) THEN * * General tridiagonal * CALL CLARNV( 2, ISEED, 3*N-2, A ) END IF * RETURN * * End of CTIMMG * END SHAR_EOF fi # end of overwriting check if test -f 'ctimmm.f' then echo shar: will not over-write existing file "'ctimmm.f'" else cat << SHAR_EOF > 'ctimmm.f' SUBROUTINE CTIMMM( VNAME, LAB2, NN, NVAL, NLDA, LDAVAL, TIMMIN, A, $ B, C, RESLTS, LDR1, LDR2, NOUT ) * * -- LAPACK timing 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*( * ) LAB2, VNAME INTEGER LDR1, LDR2, NLDA, NN, NOUT REAL TIMMIN * .. * .. Array Arguments .. INTEGER LDAVAL( * ), NVAL( * ) REAL RESLTS( LDR1, LDR2, * ) COMPLEX A( * ), B( * ), C( * ) * .. * * Purpose * ======= * * CTIMMM times CGEMM. * * Arguments * ========= * * VNAME (input) CHARACTER*(*) * The name of the Level 3 BLAS routine to be timed. * * LAB2 (input) CHARACTER*(*) * The name of the variable given in NVAL. * * NN (input) INTEGER * The number of values of N contained in the vector NVAL. * * NVAL (input) INTEGER array, dimension (NN) * The values of the matrix dimension N. * * NLDA (input) INTEGER * The number of values of LDA contained in the vector LDAVAL. * * LDAVAL (input) INTEGER array, dimension (NLDA) * The values of the leading dimension of the array A. * * TIMMIN (input) REAL * The minimum time a subroutine will be timed. * * A (workspace) COMPLEX array, dimension (LDAMAX*NMAX) * where LDAMAX and NMAX are the maximum values permitted * for LDA and N. * * B (workspace) COMPLEX array, dimension (LDAMAX*NMAX) * * C (workspace) COMPLEX array, dimension (LDAMAX*NMAX) * * RESLTS (output) REAL array, dimension (LDR1,LDR2,NLDA) * The timing results for each subroutine over the relevant * values of N and LDA. * * LDR1 (input) INTEGER * The first dimension of RESLTS. LDR1 >= 1. * * LDR2 (input) INTEGER * The second dimension of RESLTS. LDR2 >= max(1,NN). * * NOUT (input) INTEGER * The unit number for output. * * ===================================================================== * * .. Parameters .. INTEGER NSUBS COMPLEX ONE PARAMETER ( NSUBS = 1, ONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. CHARACTER*6 CNAME INTEGER I, IC, ICL, ILDA, IN, INFO, ISUB, LDA, N REAL OPS, S1, S2, TIME, UNTIME * .. * .. Local Arrays .. LOGICAL TIMSUB( NSUBS ) CHARACTER*6 SUBNAM( NSUBS ) INTEGER IDUMMY( 1 ) * .. * .. External Functions .. LOGICAL LSAMEN REAL SECOND, SMFLOP, SOPBL3 EXTERNAL LSAMEN, SECOND, SMFLOP, SOPBL3 * .. * .. External Subroutines .. EXTERNAL ATIMCK, CGEMM, CTIMMG, SPRTBL * .. * .. Intrinsic Functions .. INTRINSIC REAL * .. * .. Data statements .. DATA SUBNAM / 'CGEMM ' / * .. * .. Executable Statements .. * CNAME = VNAME DO 10 ISUB = 1, NSUBS TIMSUB( ISUB ) = LSAMEN( 6, CNAME, SUBNAM( ISUB ) ) IF( TIMSUB( ISUB ) ) $ GO TO 20 10 CONTINUE WRITE( NOUT, FMT = 9999 )CNAME GO TO 80 20 CONTINUE * * Check that N <= LDA for the input values. * CALL ATIMCK( 2, CNAME, NN, NVAL, NLDA, LDAVAL, NOUT, INFO ) IF( INFO.GT.0 ) THEN WRITE( NOUT, FMT = 9998 )CNAME GO TO 80 END IF * DO 60 ILDA = 1, NLDA LDA = LDAVAL( ILDA ) DO 50 IN = 1, NN N = NVAL( IN ) * * Time CGEMM * CALL CTIMMG( 1, N, N, A, LDA, 0, 0 ) CALL CTIMMG( 0, N, N, B, LDA, 0, 0 ) CALL CTIMMG( 1, N, N, C, LDA, 0, 0 ) IC = 0 S1 = SECOND( ) 30 CONTINUE CALL CGEMM( 'No transpose', 'No transpose', N, N, N, ONE, A, $ LDA, B, LDA, ONE, C, LDA ) S2 = SECOND( ) TIME = S2 - S1 IC = IC + 1 IF( TIME.LT.TIMMIN ) THEN CALL CTIMMG( 1, N, N, C, LDA, 0, 0 ) GO TO 30 END IF * * Subtract the time used in CTIMMG. * ICL = 1 S1 = SECOND( ) 40 CONTINUE S2 = SECOND( ) UNTIME = S2 - S1 ICL = ICL + 1 IF( ICL.LE.IC ) THEN CALL CTIMMG( 1, N, N, C, LDA, 0, 0 ) GO TO 40 END IF * TIME = ( TIME-UNTIME ) / REAL( IC ) OPS = SOPBL3( 'CGEMM ', N, N, N ) RESLTS( 1, IN, ILDA ) = SMFLOP( OPS, TIME, 0 ) 50 CONTINUE 60 CONTINUE * * Print the table of results on unit NOUT. * WRITE( NOUT, FMT = 9997 )VNAME IF( NLDA.EQ.1 ) THEN WRITE( NOUT, FMT = 9996 )LDAVAL( 1 ) ELSE DO 70 I = 1, NLDA WRITE( NOUT, FMT = 9995 )I, LDAVAL( I ) 70 CONTINUE END IF WRITE( NOUT, FMT = * ) CALL SPRTBL( ' ', LAB2, 1, IDUMMY, NN, NVAL, NLDA, RESLTS, LDR1, $ LDR2, NOUT ) * 80 CONTINUE RETURN 9999 FORMAT( 1X, A6, ': Unrecognized path or subroutine name', / ) 9998 FORMAT( 1X, A6, ' timing run not attempted', / ) 9997 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' ) 9996 FORMAT( 5X, 'with LDA = ', I5 ) 9995 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 ) * * End of CTIMMM * END SHAR_EOF fi # end of overwriting check if test -f 'ctimmv.f' then echo shar: will not over-write existing file "'ctimmv.f'" else cat << SHAR_EOF > 'ctimmv.f' SUBROUTINE CTIMMV( VNAME, NN, NVAL, NK, KVAL, NLDA, LDAVAL, $ TIMMIN, A, LB, B, C, RESLTS, LDR1, LDR2, NOUT ) * * -- LAPACK timing 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*( * ) VNAME INTEGER LB, LDR1, LDR2, NK, NLDA, NN, NOUT REAL TIMMIN * .. * .. Array Arguments .. INTEGER KVAL( * ), LDAVAL( * ), NVAL( * ) REAL RESLTS( LDR1, LDR2, * ) COMPLEX A( * ), B( * ), C( * ) * .. * * Purpose * ======= * * CTIMMV times individual BLAS 2 routines. * * Arguments * ========= * * VNAME (input) CHARACTER*(*) * The name of the Level 2 BLAS routine to be timed. * * NN (input) INTEGER * The number of values of N contained in the vector NVAL. * * NVAL (input) INTEGER array, dimension (NN) * The values of the matrix dimension N. * * NK (input) INTEGER * The number of values of K contained in the vector KVAL. * * KVAL (input) INTEGER array, dimension (NK) * The values of the bandwidth K. * * NLDA (input) INTEGER * The number of values of LDA contained in the vector LDAVAL. * * LDAVAL (input) INTEGER array, dimension (NLDA) * The values of the leading dimension of the array A. * * TIMMIN (input) REAL * The minimum time a subroutine will be timed. * * A (workspace) COMPLEX array, dimension (LDAMAX*NMAX) * where LDAMAX and NMAX are the maximum values permitted * for LDA and N. * * LB (input) INTEGER * The length of B and C, needed when timing CGBMV. If timing * CGEMV, LB >= LDAMAX*NMAX. * * B (workspace) COMPLEX array, dimension (LB) * * C (workspace) COMPLEX array, dimension (LB) * * RESLTS (output) REAL array, dimension (LDR1,LDR2,NLDA) * The timing results for each subroutine over the relevant * values of N and LDA. * * LDR1 (input) INTEGER * The first dimension of RESLTS. LDR1 >= max(1,NK). * * LDR2 (input) INTEGER * The second dimension of RESLTS. LDR2 >= max(1,NN). * * NOUT (input) INTEGER * The unit number for output. * * ===================================================================== * * .. Parameters .. INTEGER NSUBS COMPLEX ONE PARAMETER ( NSUBS = 2, ONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. CHARACTER LAB1, LAB2 CHARACTER*6 CNAME INTEGER I, IB, IC, ICL, IK, ILDA, IN, INFO, ISUB, K, $ KL, KU, LDA, LDB, N, NRHS REAL OPS, S1, S2, TIME, UNTIME * .. * .. Local Arrays .. LOGICAL TIMSUB( NSUBS ) CHARACTER*6 SUBNAM( NSUBS ) * .. * .. External Functions .. LOGICAL LSAME, LSAMEN REAL SECOND, SMFLOP, SOPBL2 EXTERNAL LSAME, LSAMEN, SECOND, SMFLOP, SOPBL2 * .. * .. External Subroutines .. EXTERNAL ATIMCK, CGBMV, CGEMV, CTIMMG, SPRTBL * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN, REAL * .. * .. Data statements .. DATA SUBNAM / 'CGEMV ', 'CGBMV ' / * .. * .. Executable Statements .. * CNAME = VNAME DO 10 ISUB = 1, NSUBS TIMSUB( ISUB ) = LSAMEN( 6, CNAME, SUBNAM( ISUB ) ) IF( TIMSUB( ISUB ) ) $ GO TO 20 10 CONTINUE WRITE( NOUT, FMT = 9999 )CNAME GO TO 150 20 CONTINUE * * Check that N or K <= LDA for the input values. * IF( LSAME( CNAME( 3: 3 ), 'B' ) ) THEN CALL ATIMCK( 0, CNAME, NK, KVAL, NLDA, LDAVAL, NOUT, INFO ) LAB1 = 'M' LAB2 = 'K' ELSE CALL ATIMCK( 2, CNAME, NN, NVAL, NLDA, LDAVAL, NOUT, INFO ) LAB1 = ' ' LAB2 = 'N' END IF IF( INFO.GT.0 ) THEN WRITE( NOUT, FMT = 9998 )CNAME GO TO 150 END IF * * Print the table header on unit NOUT. * WRITE( NOUT, FMT = 9997 )VNAME IF( NLDA.EQ.1 ) THEN WRITE( NOUT, FMT = 9996 )LDAVAL( 1 ) ELSE DO 30 I = 1, NLDA WRITE( NOUT, FMT = 9995 )I, LDAVAL( I ) 30 CONTINUE END IF WRITE( NOUT, FMT = * ) * * Time CGEMV * IF( TIMSUB( 1 ) ) THEN DO 80 ILDA = 1, NLDA LDA = LDAVAL( ILDA ) DO 70 IN = 1, NN N = NVAL( IN ) NRHS = N LDB = LDA CALL CTIMMG( 1, N, N, A, LDA, 0, 0 ) CALL CTIMMG( 0, N, NRHS, B, LDB, 0, 0 ) CALL CTIMMG( 1, N, NRHS, C, LDB, 0, 0 ) IC = 0 S1 = SECOND( ) 40 CONTINUE IB = 1 DO 50 I = 1, NRHS CALL CGEMV( 'No transpose', N, N, ONE, A, LDA, $ B( IB ), 1, ONE, C( IB ), 1 ) IB = IB + LDB 50 CONTINUE S2 = SECOND( ) TIME = S2 - S1 IC = IC + 1 IF( TIME.LT.TIMMIN ) THEN CALL CTIMMG( 1, N, NRHS, C, LDB, 0, 0 ) GO TO 40 END IF * * Subtract the time used in CTIMMG. * ICL = 1 S1 = SECOND( ) 60 CONTINUE S2 = SECOND( ) UNTIME = S2 - S1 ICL = ICL + 1 IF( ICL.LE.IC ) THEN CALL CTIMMG( 1, N, NRHS, C, LDB, 0, 0 ) GO TO 60 END IF * TIME = ( TIME-UNTIME ) / REAL( IC ) OPS = NRHS*SOPBL2( 'CGEMV ', N, N, 0, 0 ) RESLTS( 1, IN, ILDA ) = SMFLOP( OPS, TIME, 0 ) 70 CONTINUE 80 CONTINUE * CALL SPRTBL( LAB1, LAB2, 1, NVAL, NN, NVAL, NLDA, RESLTS, LDR1, $ LDR2, NOUT ) * ELSE IF( TIMSUB( 2 ) ) THEN * * Time CGBMV * DO 140 ILDA = 1, NLDA LDA = LDAVAL( ILDA ) DO 130 IN = 1, NN N = NVAL( IN ) DO 120 IK = 1, NK K = MIN( N-1, MAX( 0, KVAL( IK ) ) ) KL = K KU = K LDB = N CALL CTIMMG( 2, N, N, A, LDA, KL, KU ) NRHS = MIN( K, LB / LDB ) CALL CTIMMG( 0, N, NRHS, B, LDB, 0, 0 ) CALL CTIMMG( 1, N, NRHS, C, LDB, 0, 0 ) IC = 0 S1 = SECOND( ) 90 CONTINUE IB = 1 DO 100 I = 1, NRHS CALL CGBMV( 'No transpose', N, N, KL, KU, ONE, $ A( KU+1 ), LDA, B( IB ), 1, ONE, $ C( IB ), 1 ) IB = IB + LDB 100 CONTINUE S2 = SECOND( ) TIME = S2 - S1 IC = IC + 1 IF( TIME.LT.TIMMIN ) THEN CALL CTIMMG( 1, N, NRHS, C, LDB, 0, 0 ) GO TO 90 END IF * * Subtract the time used in CTIMMG. * ICL = 1 S1 = SECOND( ) 110 CONTINUE S2 = SECOND( ) UNTIME = S2 - S1 ICL = ICL + 1 IF( ICL.LE.IC ) THEN CALL CTIMMG( 1, N, NRHS, C, LDB, 0, 0 ) GO TO 110 END IF * TIME = ( TIME-UNTIME ) / REAL( IC ) OPS = NRHS*SOPBL2( 'CGBMV ', N, N, KL, KU ) RESLTS( IN, IK, ILDA ) = SMFLOP( OPS, TIME, 0 ) 120 CONTINUE 130 CONTINUE 140 CONTINUE * CALL SPRTBL( LAB1, LAB2, NN, NVAL, NK, KVAL, NLDA, RESLTS, $ LDR1, LDR2, NOUT ) END IF * 150 CONTINUE 9999 FORMAT( 1X, A6, ': Unrecognized path or subroutine name', / ) 9998 FORMAT( 1X, A6, ' timing run not attempted', / ) 9997 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' ) 9996 FORMAT( 5X, 'with LDA = ', I5 ) 9995 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 ) RETURN * * End of CTIMMV * END SHAR_EOF fi # end of overwriting check if test -f 'ctimqp.f' then echo shar: will not over-write existing file "'ctimqp.f'" else cat << SHAR_EOF > 'ctimqp.f' SUBROUTINE CTIMQP( LINE, NM, MVAL, NVAL, NLDA, LDAVAL, TIMMIN, A, $ COPYA, TAU, WORK, RWORK, IWORK, RESLTS, LDR1, $ LDR2, NOUT ) * * -- LAPACK timing routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER*80 LINE INTEGER LDR1, LDR2, NLDA, NM, NOUT REAL TIMMIN * .. * .. Array Arguments .. INTEGER IWORK( * ), LDAVAL( * ), MVAL( * ), NVAL( * ) REAL RESLTS( LDR1, LDR2, * ), RWORK( * ) COMPLEX A( * ), COPYA( * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * CTIMQP times the LAPACK routines to perform the QR factorization with * column pivoting of a COMPLEX general matrix. * * Two matrix types may be used for timing. The number of types is * set in the parameter NMODE and the matrix types are set in the vector * MODES, using the following key: * 2. BREAK1 D(1:N-1)=1 and D(N)=1.0/COND in CLATMS * 3. GEOM D(I)=COND**(-(I-1)/(N-1)) in CLATMS * These numbers are chosen to correspond with the matrix types in the * test code. * * Arguments * ========= * * LINE (input) CHARACTER*80 * The input line that requested this routine. The first six * characters contain either the name of a subroutine or a * generic path name. The remaining characters may be used to * specify the individual routines to be timed. See ATIMIN for * a full description of the format of the input line. * * NM (input) INTEGER * The number of values of M and N contained in the vectors * MVAL and NVAL. The matrix sizes are used in pairs (M,N). * * MVAL (input) INTEGER array, dimension (NM) * The values of the matrix row dimension M. * * NVAL (input) INTEGER array, dimension (NM) * The values of the matrix column dimension N. * * NLDA (input) INTEGER * The number of values of LDA contained in the vector LDAVAL. * * LDAVAL (input) INTEGER array, dimension (NLDA) * The values of the leading dimension of the array A. * * TIMMIN (input) REAL * The minimum time a subroutine will be timed. * * A (workspace) COMPLEX array, dimension (LDAMAX*NMAX) * where LDAMAX and NMAX are the maximum values of LDA and N. * * COPYA (workspace) COMPLEX array, dimension (LDAMAX*NMAX) * * TAU (workspace) COMPLEX array, dimension (min(M,N)) * * WORK (workspace) COMPLEX array, dimension (3*max(MMAX,NMAX)) * * RWORK (workspace) REAL array, dimension (2*NMAX) * * IWORK (workspace) INTEGER array, dimension (2*NMAX) * * RESLTS (workspace) REAL array, dimension * (LDR1,LDR2,NLDA) * The timing results for each subroutine over the relevant * values of MODE, (M,N), and LDA. * * LDR1 (input) INTEGER * The first dimension of RESLTS. LDR1 >= max(1,NM). * * LDR2 (input) INTEGER * The second dimension of RESLTS. LDR2 >= max(1,NM). * * NOUT (input) INTEGER * The unit number for output. * * ===================================================================== * * .. Parameters .. INTEGER NSUBS, NMODE PARAMETER ( NSUBS = 1, NMODE = 2 ) REAL ONE PARAMETER ( ONE = 1.0E+0 ) * .. * .. Local Scalars .. CHARACTER*3 PATH CHARACTER*6 CNAME INTEGER I, IC, ICL, ILDA, IM, IMODE, INFO, LDA, M, $ MINMN, MODE, N, NB REAL COND, DMAX, OPS, S1, S2, TIME, UNTIME * .. * .. Local Arrays .. LOGICAL TIMSUB( NSUBS ) CHARACTER*6 SUBNAM( NSUBS ) INTEGER ISEED( 4 ), MODES( NMODE ) * .. * .. External Functions .. REAL SECOND, SLAMCH, SMFLOP, SOPLA EXTERNAL SECOND, SLAMCH, SMFLOP, SOPLA * .. * .. External Subroutines .. EXTERNAL ATIMCK, ATIMIN, CGEQPF, CLACPY, CLATMS, ICOPY, $ SPRTB5 * .. * .. Intrinsic Functions .. INTRINSIC MIN, REAL * .. * .. Data statements .. DATA SUBNAM / 'CGEQPF' / DATA MODES / 2, 3 / DATA ISEED / 0, 0, 0, 1 / * .. * .. Executable Statements .. * * Extract the timing request from the input line. * PATH( 1: 1 ) = 'Complex precision' PATH( 2: 3 ) = 'QP' CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO ) IF( .NOT.TIMSUB( 1 ) .OR. INFO.NE.0 ) $ GO TO 90 * * Check that M <= LDA for the input values. * CNAME = LINE( 1: 6 ) CALL ATIMCK( 1, CNAME, NM, MVAL, NLDA, LDAVAL, NOUT, INFO ) IF( INFO.GT.0 ) THEN WRITE( NOUT, FMT = 9999 )CNAME GO TO 90 END IF * * Set the condition number and scaling factor for the matrices * to be generated. * DMAX = ONE COND = ONE / SLAMCH( 'Precision' ) * * Do for each pair of values (M,N): * DO 60 IM = 1, NM M = MVAL( IM ) N = NVAL( IM ) MINMN = MIN( M, N ) * * Do for each value of LDA: * DO 50 ILDA = 1, NLDA LDA = LDAVAL( ILDA ) DO 40 IMODE = 1, NMODE MODE = MODES( IMODE ) * * Generate a test matrix of size m by n using the * singular value distribution indicated by MODE. * DO 10 I = 1, N IWORK( N+I ) = 0 10 CONTINUE CALL CLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', RWORK, $ MODE, COND, DMAX, M, N, 'No packing', COPYA, $ LDA, WORK, INFO ) * * CGEQPF: QR factorization with column pivoting * CALL CLACPY( 'All', M, N, COPYA, LDA, A, LDA ) CALL ICOPY( N, IWORK( N+1 ), 1, IWORK, 1 ) IC = 0 S1 = SECOND( ) 20 CONTINUE CALL CGEQPF( M, N, A, LDA, IWORK, TAU, WORK, RWORK, $ INFO ) S2 = SECOND( ) TIME = S2 - S1 IC = IC + 1 IF( TIME.LT.TIMMIN ) THEN CALL CLACPY( 'All', M, N, COPYA, LDA, A, LDA ) CALL ICOPY( N, IWORK( N+1 ), 1, IWORK, 1 ) GO TO 20 END IF * * Subtract the time used in CLACPY and ICOPY. * ICL = 1 S1 = SECOND( ) 30 CONTINUE S2 = SECOND( ) UNTIME = S2 - S1 ICL = ICL + 1 IF( ICL.LE.IC ) THEN CALL CLACPY( 'All', M, N, COPYA, LDA, A, LDA ) CALL ICOPY( N, IWORK( N+1 ), 1, IWORK, 1 ) GO TO 30 END IF * TIME = ( TIME-UNTIME ) / REAL( IC ) OPS = SOPLA( 'CGEQPF', M, N, 0, 0, NB ) RESLTS( IMODE, IM, ILDA ) = SMFLOP( OPS, TIME, INFO ) * 40 CONTINUE 50 CONTINUE 60 CONTINUE * * Print tables of results * WRITE( NOUT, FMT = 9998 )SUBNAM( 1 ) IF( NLDA.GT.1 ) THEN DO 70 I = 1, NLDA WRITE( NOUT, FMT = 9997 )I, LDAVAL( I ) 70 CONTINUE END IF WRITE( NOUT, FMT = * ) CALL SPRTB5( 'Type', 'M', 'N', NMODE, MODES, NM, MVAL, NVAL, NLDA, $ RESLTS, LDR1, LDR2, NOUT ) 90 CONTINUE 9999 FORMAT( 1X, A6, ' timing run not attempted', / ) 9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' ) 9997 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 ) RETURN * * End of CTIMQP * END SHAR_EOF fi # end of overwriting check if test -f 'ctimqr.f' then echo shar: will not over-write existing file "'ctimqr.f'" else cat << SHAR_EOF > 'ctimqr.f' SUBROUTINE CTIMQR( LINE, NM, MVAL, NVAL, NK, KVAL, NNB, NBVAL, $ NXVAL, NLDA, LDAVAL, TIMMIN, A, TAU, B, WORK, $ RWORK, RESLTS, LDR1, LDR2, LDR3, NOUT ) * * -- LAPACK timing routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER*80 LINE INTEGER LDR1, LDR2, LDR3, NK, NLDA, NM, NNB, NOUT REAL TIMMIN * .. * .. Array Arguments .. INTEGER KVAL( * ), LDAVAL( * ), MVAL( * ), NBVAL( * ), $ NVAL( * ), NXVAL( * ) REAL RESLTS( LDR1, LDR2, LDR3, * ), RWORK( * ) COMPLEX A( * ), B( * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * CTIMQR times the LAPACK routines to perform the QR factorization of * a COMPLEX general matrix. * * Arguments * ========= * * LINE (input) CHARACTER*80 * The input line that requested this routine. The first six * characters contain either the name of a subroutine or a * generic path name. The remaining characters may be used to * specify the individual routines to be timed. See ATIMIN for * a full description of the format of the input line. * * NM (input) INTEGER * The number of values of M and N contained in the vectors * MVAL and NVAL. The matrix sizes are used in pairs (M,N). * * MVAL (input) INTEGER array, dimension (NM) * The values of the matrix row dimension M. * * NVAL (input) INTEGER array, dimension (NM) * The values of the matrix column dimension N. * * NK (input) INTEGER * The number of values of K in the vector KVAL. * * KVAL (input) INTEGER array, dimension (NK) * The values of the matrix dimension K, used in CUNMQR. * * NNB (input) INTEGER * The number of values of NB and NX contained in the * vectors NBVAL and NXVAL. The blocking parameters are used * in pairs (NB,NX). * * NBVAL (input) INTEGER array, dimension (NNB) * The values of the blocksize NB. * * NXVAL (input) INTEGER array, dimension (NNB) * The values of the crossover point NX. * * NLDA (input) INTEGER * The number of values of LDA contained in the vector LDAVAL. * * LDAVAL (input) INTEGER array, dimension (NLDA) * The values of the leading dimension of the array A. * * TIMMIN (input) REAL * The minimum time a subroutine will be timed. * * A (workspace) COMPLEX array, dimension (LDAMAX*NMAX) * where LDAMAX and NMAX are the maximum values of LDA and N. * * TAU (workspace) COMPLEX array, dimension (min(M,N)) * * B (workspace) COMPLEX array, dimension (LDAMAX*NMAX) * * WORK (workspace) COMPLEX array, dimension (LDAMAX*NBMAX) * where NBMAX is the maximum value of NB. * * RWORK (workspace) REAL array, dimension * (min(MMAX,NMAX)) * * RESLTS (workspace) REAL array, dimension * (LDR1,LDR2,LDR3,2*NK) * The timing results for each subroutine over the relevant * values of (M,N), (NB,NX), and LDA. * * LDR1 (input) INTEGER * The first dimension of RESLTS. LDR1 >= max(1,NNB). * * LDR2 (input) INTEGER * The second dimension of RESLTS. LDR2 >= max(1,NM). * * LDR3 (input) INTEGER * The third dimension of RESLTS. LDR3 >= max(1,NLDA). * * NOUT (input) INTEGER * The unit number for output. * * Internal Parameters * =================== * * MODE INTEGER * The matrix type. MODE = 3 is a geometric distribution of * eigenvalues. See CLATMS for further details. * * COND REAL * The condition number of the matrix. The singular values are * set to values from DMAX to DMAX/COND. * * DMAX REAL * The magnitude of the largest singular value. * * ===================================================================== * * .. Parameters .. INTEGER NSUBS PARAMETER ( NSUBS = 3 ) INTEGER MODE REAL COND, DMAX PARAMETER ( MODE = 3, COND = 100.0E0, DMAX = 1.0E0 ) * .. * .. Local Scalars .. CHARACTER LABM, SIDE, TRANS CHARACTER*3 PATH CHARACTER*6 CNAME INTEGER I, I4, IC, ICL, IK, ILDA, IM, IMX, INB, INFO, $ ISIDE, ISUB, ITOFF, ITRAN, K, K1, LDA, LW, M, $ M1, MINMN, N, N1, NB, NX REAL OPS, S1, S2, TIME, UNTIME * .. * .. Local Arrays .. LOGICAL TIMSUB( NSUBS ) CHARACTER SIDES( 2 ), TRANSS( 2 ) CHARACTER*6 SUBNAM( NSUBS ) INTEGER ISEED( 4 ), MUSE( 12 ), NUSE( 12 ), RESEED( 4 ) * .. * .. External Functions .. REAL SECOND, SMFLOP, SOPLA EXTERNAL SECOND, SMFLOP, SOPLA * .. * .. External Subroutines .. EXTERNAL ATIMCK, ATIMIN, CGEQRF, CLACPY, CLATMS, CTIMMG, $ CUNGQR, CUNMQR, ICOPY, SPRTB4, SPRTB5, XLAENV * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN, REAL * .. * .. Data statements .. DATA SUBNAM / 'CGEQRF', 'CUNGQR', 'CUNMQR' / DATA SIDES / 'L', 'R' / , TRANSS / 'N', 'C' / DATA ISEED / 0, 0, 0, 1 / * .. * .. Executable Statements .. * * Extract the timing request from the input line. * PATH( 1: 1 ) = 'Complex precision' PATH( 2: 3 ) = 'QR' CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO ) IF( INFO.NE.0 ) $ GO TO 230 * * Check that M <= LDA for the input values. * CNAME = LINE( 1: 6 ) CALL ATIMCK( 1, CNAME, NM, MVAL, NLDA, LDAVAL, NOUT, INFO ) IF( INFO.GT.0 ) THEN WRITE( NOUT, FMT = 9999 )CNAME GO TO 230 END IF * * Do for each pair of values (M,N): * DO 70 IM = 1, NM M = MVAL( IM ) N = NVAL( IM ) MINMN = MIN( M, N ) CALL ICOPY( 4, ISEED, 1, RESEED, 1 ) * * Do for each value of LDA: * DO 60 ILDA = 1, NLDA LDA = LDAVAL( ILDA ) * * Do for each pair of values (NB, NX) in NBVAL and NXVAL. * DO 50 INB = 1, NNB NB = NBVAL( INB ) CALL XLAENV( 1, NB ) NX = NXVAL( INB ) CALL XLAENV( 3, NX ) LW = MAX( 1, N*MAX( 1, NB ) ) CALL ICOPY( 4, RESEED, 1, ISEED, 1 ) * * Generate a test matrix of size M by N. * CALL CLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', RWORK, $ MODE, COND, DMAX, M, N, 'No packing', B, $ LDA, WORK, INFO ) * IF( TIMSUB( 1 ) ) THEN * * CGEQRF: QR factorization * CALL CLACPY( 'Full', M, N, B, LDA, A, LDA ) IC = 0 S1 = SECOND( ) 10 CONTINUE CALL CGEQRF( M, N, A, LDA, TAU, WORK, LW, INFO ) S2 = SECOND( ) TIME = S2 - S1 IC = IC + 1 IF( TIME.LT.TIMMIN ) THEN CALL CLACPY( 'Full', M, N, B, LDA, A, LDA ) GO TO 10 END IF * * Subtract the time used in CLACPY. * ICL = 1 S1 = SECOND( ) 20 CONTINUE S2 = SECOND( ) UNTIME = S2 - S1 ICL = ICL + 1 IF( ICL.LE.IC ) THEN CALL CLACPY( 'Full', M, N, A, LDA, B, LDA ) GO TO 20 END IF * TIME = ( TIME-UNTIME ) / REAL( IC ) OPS = SOPLA( 'CGEQRF', M, N, 0, 0, NB ) RESLTS( INB, IM, ILDA, 1 ) = SMFLOP( OPS, TIME, INFO ) ELSE * * If CGEQRF was not timed, generate a matrix and factor * it using CGEQRF anyway so that the factored form of * the matrix can be used in timing the other routines. * CALL CLACPY( 'Full', M, N, B, LDA, A, LDA ) CALL CGEQRF( M, N, A, LDA, TAU, WORK, LW, INFO ) END IF * IF( TIMSUB( 2 ) ) THEN * * CUNGQR: Generate orthogonal matrix Q from the QR * factorization * CALL CLACPY( 'Full', M, MINMN, A, LDA, B, LDA ) IC = 0 S1 = SECOND( ) 30 CONTINUE CALL CUNGQR( M, MINMN, MINMN, B, LDA, TAU, WORK, LW, $ INFO ) S2 = SECOND( ) TIME = S2 - S1 IC = IC + 1 IF( TIME.LT.TIMMIN ) THEN CALL CLACPY( 'Full', M, MINMN, A, LDA, B, LDA ) GO TO 30 END IF * * Subtract the time used in CLACPY. * ICL = 1 S1 = SECOND( ) 40 CONTINUE S2 = SECOND( ) UNTIME = S2 - S1 ICL = ICL + 1 IF( ICL.LE.IC ) THEN CALL CLACPY( 'Full', M, MINMN, A, LDA, B, LDA ) GO TO 40 END IF * TIME = ( TIME-UNTIME ) / REAL( IC ) OPS = SOPLA( 'CUNGQR', M, MINMN, MINMN, 0, NB ) RESLTS( INB, IM, ILDA, 2 ) = SMFLOP( OPS, TIME, INFO ) END IF * 50 CONTINUE 60 CONTINUE 70 CONTINUE * * Print tables of results * DO 90 ISUB = 1, NSUBS - 1 IF( .NOT.TIMSUB( ISUB ) ) $ GO TO 90 WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB ) IF( NLDA.GT.1 ) THEN DO 80 I = 1, NLDA WRITE( NOUT, FMT = 9997 )I, LDAVAL( I ) 80 CONTINUE END IF WRITE( NOUT, FMT = * ) IF( ISUB.EQ.2 ) $ WRITE( NOUT, FMT = 9996 ) CALL SPRTB4( '( NB, NX)', 'M', 'N', NNB, NBVAL, NXVAL, NM, $ MVAL, NVAL, NLDA, RESLTS( 1, 1, 1, ISUB ), LDR1, $ LDR2, NOUT ) 90 CONTINUE * * Time CUNMQR separately. Here the starting matrix is M by N, and * K is the free dimension of the matrix multiplied by Q. * IF( TIMSUB( 3 ) ) THEN * * Check that K <= LDA for the input values. * CALL ATIMCK( 3, CNAME, NK, KVAL, NLDA, LDAVAL, NOUT, INFO ) IF( INFO.GT.0 ) THEN WRITE( NOUT, FMT = 9999 )SUBNAM( 3 ) GO TO 230 END IF * * Use only the pairs (M,N) where M >= N. * IMX = 0 DO 100 IM = 1, NM IF( MVAL( IM ).GE.NVAL( IM ) ) THEN IMX = IMX + 1 MUSE( IMX ) = MVAL( IM ) NUSE( IMX ) = NVAL( IM ) END IF 100 CONTINUE * * CUNMQR: Multiply by Q stored as a product of elementary * transformations * * Do for each pair of values (M,N): * DO 180 IM = 1, IMX M = MUSE( IM ) N = NUSE( IM ) * * Do for each value of LDA: * DO 170 ILDA = 1, NLDA LDA = LDAVAL( ILDA ) * * Generate an M by N matrix and form its QR decomposition. * CALL CLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', RWORK, $ MODE, COND, DMAX, M, N, 'No packing', A, $ LDA, WORK, INFO ) LW = MAX( 1, N*MAX( 1, NB ) ) CALL CGEQRF( M, N, A, LDA, TAU, WORK, LW, INFO ) * * Do first for SIDE = 'L', then for SIDE = 'R' * I4 = 0 DO 160 ISIDE = 1, 2 SIDE = SIDES( ISIDE ) * * Do for each pair of values (NB, NX) in NBVAL and * NXVAL. * DO 150 INB = 1, NNB NB = NBVAL( INB ) CALL XLAENV( 1, NB ) NX = NXVAL( INB ) CALL XLAENV( 3, NX ) * * Do for each value of K in KVAL * DO 140 IK = 1, NK K = KVAL( IK ) * * Sort out which variable is which * IF( ISIDE.EQ.1 ) THEN M1 = M K1 = N N1 = K LW = MAX( 1, N1*MAX( 1, NB ) ) ELSE N1 = M K1 = N M1 = K LW = MAX( 1, M1*MAX( 1, NB ) ) END IF * * Do first for TRANS = 'N', then for TRANS = 'T' * ITOFF = 0 DO 130 ITRAN = 1, 2 TRANS = TRANSS( ITRAN ) CALL CTIMMG( 0, M1, N1, B, LDA, 0, 0 ) IC = 0 S1 = SECOND( ) 110 CONTINUE CALL CUNMQR( SIDE, TRANS, M1, N1, K1, A, LDA, $ TAU, B, LDA, WORK, LW, INFO ) S2 = SECOND( ) TIME = S2 - S1 IC = IC + 1 IF( TIME.LT.TIMMIN ) THEN CALL CTIMMG( 0, M1, N1, B, LDA, 0, 0 ) GO TO 110 END IF * * Subtract the time used in CTIMMG. * ICL = 1 S1 = SECOND( ) 120 CONTINUE S2 = SECOND( ) UNTIME = S2 - S1 ICL = ICL + 1 IF( ICL.LE.IC ) THEN CALL CTIMMG( 0, M1, N1, B, LDA, 0, 0 ) GO TO 120 END IF * TIME = ( TIME-UNTIME ) / REAL( IC ) OPS = SOPLA( 'CUNMQR', M1, N1, K1, ISIDE-1, $ NB ) RESLTS( INB, IM, ILDA, $ I4+ITOFF+IK ) = SMFLOP( OPS, TIME, INFO ) ITOFF = NK 130 CONTINUE 140 CONTINUE 150 CONTINUE I4 = 2*NK 160 CONTINUE 170 CONTINUE 180 CONTINUE * * Print tables of results * ISUB = 3 I4 = 1 IF( IMX.GE.1 ) THEN DO 220 ISIDE = 1, 2 SIDE = SIDES( ISIDE ) IF( ISIDE.EQ.1 ) THEN WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB ) IF( NLDA.GT.1 ) THEN DO 190 I = 1, NLDA WRITE( NOUT, FMT = 9997 )I, LDAVAL( I ) 190 CONTINUE END IF END IF DO 210 ITRAN = 1, 2 TRANS = TRANSS( ITRAN ) DO 200 IK = 1, NK IF( ISIDE.EQ.1 ) THEN N = KVAL( IK ) WRITE( NOUT, FMT = 9995 )SUBNAM( ISUB ), SIDE, $ TRANS, 'N', N LABM = 'M' ELSE M = KVAL( IK ) WRITE( NOUT, FMT = 9995 )SUBNAM( ISUB ), SIDE, $ TRANS, 'M', M LABM = 'N' END IF CALL SPRTB5( 'NB', LABM, 'K', NNB, NBVAL, IMX, $ MUSE, NUSE, NLDA, $ RESLTS( 1, 1, 1, I4 ), LDR1, LDR2, $ NOUT ) I4 = I4 + 1 200 CONTINUE 210 CONTINUE 220 CONTINUE ELSE WRITE( NOUT, FMT = 9994 )SUBNAM( ISUB ) END IF END IF 230 CONTINUE 9999 FORMAT( 1X, A6, ' timing run not attempted', / ) 9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' ) 9997 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 ) 9996 FORMAT( 5X, 'K = min(M,N)', / ) 9995 FORMAT( / 5X, A6, ' with SIDE = ''', A1, ''', TRANS = ''', A1, $ ''', ', A1, ' =', I6, / ) 9994 FORMAT( ' *** No pairs (M,N) found with M >= N: ', A6, $ ' not timed' ) RETURN * * End of CTIMQR * END SHAR_EOF fi # end of overwriting check if test -f 'ctimrr.f' then echo shar: will not over-write existing file "'ctimrr.f'" else cat << SHAR_EOF > 'ctimrr.f' SUBROUTINE CTIMRR( LINE, NM, MVAL, NVAL, NK, KVAL, $ NNB, NBVAL, NXVAL, NLDA, LDAVAL, TIMMIN, $ A, COPYA, B, WORK, RWORK, IWORK, RESLTS, $ LDR1, LDR2, NOUT ) * * -- LAPACK timing routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * Rewritten for timing rrqr code. * * .. Scalar Arguments .. CHARACTER*80 LINE INTEGER LDR1, LDR2, NK, NLDA, NM, NNB, NOUT REAL TIMMIN * .. * .. Array Arguments .. INTEGER IWORK( * ), KVAL( * ), LDAVAL( * ), MVAL( * ), $ NBVAL( * ), NVAL( * ), NXVAL( * ) REAL RESLTS( LDR1, LDR2, * ), RWORK( * ) COMPLEX A( * ), COPYA( * ), B( * ), WORK( * ) * .. * * Purpose * ======= * * CTIMRR times the Rank-Revealing QR factorization of a * COMPLEX general matrix. * * Two matrix types may be used for timing. The number of types is * set in the parameter NMODE and the matrix types are set in the vector * MODES, using the following key: * 2. BREAK1 D(1:N-1)=1 and D(N)=1.0/COND in CLATMS * 3. GEOM D(I)=COND**(-(I-1)/(N-1)) in CLATMS * These numbers are chosen to correspond with the matrix types in the * test code. * * Arguments * ========= * * LINE (input) CHARACTER*80 * The input line that requested this routine. The first six * characters contain either the name of a subroutine or a * generic path name. The remaining characters may be used to * specify the individual routines to be timed. See ATIMIN for * a full description of the format of the input line. * * NM (input) INTEGER * The number of values of M and N contained in the vectors * MVAL and NVAL. The matrix sizes are used in pairs (M,N). * * MVAL (input) INTEGER array, dimension (NM) * The values of the matrix row dimension M. * * NVAL (input) INTEGER array, dimension (NM) * The values of the matrix column dimension N. * * NK (input) INTEGER * The number of values of K in the vector KVAL. * * KVAL (input) INTEGER array, dimension (NK) * The values of the matrix dimension K, used in SORMQR. * * NNB (input) INTEGER * The number of values of NB and NX contained in the * vectors NBVAL and NXVAL. The blocking parameters are used * in pairs (NB,NX). * * NBVAL (input) INTEGER array, dimension (NNB) * The values of the blocksize NB. * * NXVAL (input) INTEGER array, dimension (NNB) * The values of the crossover point NX. * * NLDA (input) INTEGER * The number of values of LDA contained in the vector LDAVAL. * * LDAVAL (input) INTEGER array, dimension (NLDA) * The values of the leading dimension of the array A. * * TIMMIN (input) REAL * The minimum time a subroutine will be timed. * * A (workspace) COMPLEX array, dimension (LDAMAX*NMAX) * where LDAMAX and NMAX are the maximum values of LDA and N. * * COPYA (workspace) COMPLEX array, dimension (LDAMAX*NMAX) * * B (workspace) COMPLEX array, dimension (LDAMAX*NMAX) * * * WORK (workspace) COMPLEX array, dimension (3*max(MMAX,NMAX)) * * RWORK (workspace) REAL array, dimension (2*NMAX) * * IWORK (workspace) INTEGER array, dimension (NMAX) * * RESLTS (workspace) REAL array, dimension * (LDR1,LDR2,NLDA) * The timing results for each subroutine over the relevant * values of MODE, (M,N), and LDA. * * LDR1 (input) INTEGER * The first dimension of RESLTS. LDR1 >= max(1,NM). * * LDR2 (input) INTEGER * The second dimension of RESLTS. LDR2 >= max(1,NM). * * NOUT (input) INTEGER * The unit number for output. * * ===================================================================== * * .. Parameters .. INTEGER NSUBS, NMODE PARAMETER ( NSUBS = 2, NMODE = 2 ) REAL ONE PARAMETER ( ONE = 1.0E+0 ) * .. * .. Local Scalars .. CHARACTER*3 PATH CHARACTER*6 CNAME INTEGER I, IC, ICL, ILDA, IM, IMODE, INB, INFO, IK, $ JOB, K, LDA, LW, M, MINMN, MODE, N, NX, NB, $ RANK REAL COND, DMAX, OPS, IRCOND, ORCOND, S1, S2, $ TIME, UNTIME * .. * .. Local Arrays .. LOGICAL TIMSUB( NSUBS ) CHARACTER*6 SUBNAM( NSUBS ) INTEGER ISEED( 4 ), MODES( NMODE ) REAL SVLUES( 4 ) * .. * .. External Functions .. REAL SLAMCH, SMFLOP, SOPLA, SECOND EXTERNAL SLAMCH, SMFLOP, SOPLA, SECOND * .. * .. External Subroutines .. EXTERNAL ATIMCK, ATIMIN, CGEQPX, CGEQPY, $ CLACPY, CLATMS * .. * .. Intrinsic Functions .. INTRINSIC REAL, MIN * .. * .. Data statements .. DATA SUBNAM / 'CGEQPX', 'CGEQPY' / DATA MODES / 2, 3 / DATA ISEED / 0, 0, 0, 1 / * .. * .. Executable Statements .. * * Extract the timing request from the input line. * PATH( 1: 1 ) = 'Complex precision' PATH( 2: 3 ) = 'RR' CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO ) IF( .NOT.TIMSUB( 1 ) .OR. INFO.NE.0 ) $ GO TO 1000 * * Check that M <= LDA for the input values. * CNAME = LINE( 1: 6 ) CALL ATIMCK( 1, CNAME, NM, MVAL, NLDA, LDAVAL, NOUT, INFO ) IF( INFO.GT.0 ) THEN WRITE( NOUT, FMT = 9999 )CNAME GO TO 1000 END IF * * Set the condition number and scaling factor for the matrices * to be generated. * DMAX = ONE IRCOND = SLAMCH( 'Precision' ) COND = ONE / IRCOND * * Do for each value of K: * DO 10 IK = 1, NK K = KVAL( IK ) IF( K.EQ.0 ) THEN JOB = 1 ELSE JOB = 2 END IF * * Do for each type of matrix: * DO 20 IMODE = 1, NMODE MODE = MODES( IMODE ) * * * ***************** * * Timing xGEQPX * * ***************** * * Do for each value of LDA: * DO 30 ILDA = 1, NLDA LDA = LDAVAL( ILDA ) * * Do for each pair of values (M,N): * DO 40 IM = 1, NM M = MVAL( IM ) N = NVAL( IM ) MINMN = MIN( M, N ) * * Generate a test matrix of size m by n using the * singular value distribution indicated by MODE. * CALL CLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', $ RWORK, MODE, COND, DMAX, M, N, $ 'No packing', COPYA, LDA, WORK, INFO ) * * Do for each pair of values ( NB, NX ) in NBVAL and NXVAL: * DO 50 INB = 1, NNB NB = NBVAL( INB ) CALL XLAENV( 1, NB ) NX = NXVAL( INB ) CALL XLAENV( 3, NX ) * IF( JOB.EQ.1 ) THEN IF( NB.LT.3 ) THEN LW = MAX( 1, 2*MINMN+3*N ) ELSE LW = MAX( 1, 2*MINMN+NB*N ) END IF ELSE IF( NB.LT.3 ) THEN LW = MAX( 1, 2*MINMN+2*N+MAX(K,N) ) ELSE LW = MAX( 1, 2*MINMN+NB*NB+NB*MAX(K,N) ) END IF END IF * * CGEQPX: RRQR factorization * CALL CLACPY( 'All', M, N, COPYA, LDA, A, LDA ) IC = 0 S1 = SECOND( ) 60 CONTINUE * CALL CGEQPX( JOB, M, N, K, A, LDA, B, LDA, $ IWORK, IRCOND, ORCOND, RANK, SVLUES, $ WORK, LW, RWORK, INFO ) S2 = SECOND( ) * IF( INFO.NE.0 ) THEN WRITE( *,* ) '>>>Warning: INFO returned by ', $ 'CGEQPX is:', INFO INFO = 0 END IF * TIME = S2 - S1 IC = IC + 1 IF( TIME.LT.TIMMIN ) THEN CALL CLACPY( 'All', M, N, COPYA, LDA, $ A, LDA ) GO TO 60 END IF * * Subtract the time used in CLACPY. * ICL = 1 S1 = SECOND( ) 70 CONTINUE S2 = SECOND( ) UNTIME = S2 - S1 ICL = ICL + 1 IF( ICL.LE.IC ) THEN CALL CLACPY( 'All', M, N, COPYA, LDA, $ A, LDA ) GO TO 70 END IF * TIME = ( TIME-UNTIME ) / REAL( IC ) * * The number of flops of yGEQPX is approximately the * the number of flops of yGEQPF plus the number of * flops required by yUNMQR to update matrix C. * OPS = SOPLA( 'CGEQPF', M, N, 0, 0, NB ) $ + SOPLA( 'CUNMQR', M, K, MINMN, 0, NB ) RESLTS( INB, IM, ILDA ) = $ SMFLOP( OPS, TIME, INFO ) * 50 CONTINUE 40 CONTINUE 30 CONTINUE * * Print the results for each value of K and type of matrix. * WRITE( NOUT, FMT = 9995 )SUBNAM( 1 ) WRITE( NOUT, FMT = 9996 )K, IMODE DO 90 I = 1, NLDA WRITE( NOUT, FMT = 9997 )I,LDAVAL( I ) 90 CONTINUE WRITE( NOUT, FMT = * ) CALL SPRTB4( '( NB, NX)', 'M', 'N', NNB, NBVAL, $ NXVAL, NM, MVAL, NVAL, NLDA, RESLTS( 1, 1, 1 ), $ LDR1, LDR2, NOUT ) * * * ***************** * * Timing xGEQPY * * ***************** * * Do for each value of LDA: * DO 200 ILDA = 1, NLDA LDA = LDAVAL( ILDA ) * * Do for each pair of values (M,N): * DO 210 IM = 1, NM M = MVAL( IM ) N = NVAL( IM ) MINMN = MIN( M, N ) * * Generate a test matrix of size m by n using the * singular value distribution indicated by MODE. * CALL CLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', $ RWORK, MODE, COND, DMAX, M, N, $ 'No packing', COPYA, LDA, WORK, INFO ) * * Do for each pair of values ( NB, NX ) in NBVAL and NXVAL: * DO 220 INB = 1, NNB NB = NBVAL( INB ) CALL XLAENV( 1, NB ) NX = NXVAL( INB ) CALL XLAENV( 3, NX ) * IF( JOB.EQ.1 ) THEN IF( NB.LT.3 ) THEN LW = MAX( 1, 2*MINMN+3*N ) ELSE LW = MAX( 1, 2*MINMN+NB*N ) END IF ELSE IF( NB.LT.3 ) THEN LW = MAX( 1, 2*MINMN+2*N+MAX(K,N) ) ELSE LW = MAX( 1, 2*MINMN+NB*NB+NB*MAX(K,N) ) END IF END IF * * CGEQPY: RRQR factorization * CALL CLACPY( 'All', M, N, COPYA, LDA, A, LDA ) IC = 0 S1 = SECOND( ) 230 CONTINUE * CALL CGEQPY( JOB, M, N, K, A, LDA, B, LDA, $ IWORK, IRCOND, ORCOND, RANK, SVLUES, $ WORK, LW, RWORK, INFO ) S2 = SECOND( ) * IF( INFO.NE.0 ) THEN WRITE( *,* ) '>>>Warning: INFO returned by ', $ 'CGEQPY is:', INFO INFO = 0 END IF * TIME = S2 - S1 IC = IC + 1 IF( TIME.LT.TIMMIN ) THEN CALL CLACPY( 'All', M, N, COPYA, LDA, $ A, LDA ) GO TO 230 END IF * * Subtract the time used in CLACPY. * ICL = 1 S1 = SECOND( ) 240 CONTINUE S2 = SECOND( ) UNTIME = S2 - S1 ICL = ICL + 1 IF( ICL.LE.IC ) THEN CALL CLACPY( 'All', M, N, COPYA, LDA, $ A, LDA ) GO TO 240 END IF * * The number of flops of yGEQPY is approximately the * the number of flops of yGEQPF plus the number of * flops required by yUNMQR to update matrix C. * TIME = ( TIME-UNTIME ) / REAL( IC ) * OPS = SOPLA( 'CGEQPF', M, N, 0, 0, NB ) $ + SOPLA( 'CUNMQR', M, K, MINMN, 0, NB ) RESLTS( INB, IM, ILDA ) = $ SMFLOP( OPS, TIME, INFO ) * 220 CONTINUE 210 CONTINUE 200 CONTINUE * * Print the results for each value of K and type of matrix. * WRITE( NOUT, FMT = 9995 )SUBNAM( 2 ) WRITE( NOUT, FMT = 9996 )K, IMODE DO 250 I = 1, NLDA WRITE( NOUT, FMT = 9997 )I,LDAVAL( I ) 250 CONTINUE WRITE( NOUT, FMT = * ) CALL SPRTB4( '( NB, NX)', 'M', 'N', NNB, NBVAL, $ NXVAL, NM, MVAL, NVAL, NLDA, RESLTS( 1, 1, 1 ), $ LDR1, LDR2, NOUT ) * * 20 CONTINUE 10 CONTINUE * 9995 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' ) 9996 FORMAT( 5X, 'with K = ', I4, ' and type of matrix:', I4 ) 9997 FORMAT( 5X, 'line ', I4, ' with LDA = ', I4 ) 9999 FORMAT( 1X, A6, ' timing run not attempted', / ) * 1000 CONTINUE RETURN * * End of CTIMRR * END SHAR_EOF fi # end of overwriting check if test -f 'dmflop.f' then echo shar: will not over-write existing file "'dmflop.f'" else cat << SHAR_EOF > 'dmflop.f' DOUBLE PRECISION FUNCTION DMFLOP( OPS, TIME, INFO ) * * -- LAPACK timing routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. INTEGER INFO DOUBLE PRECISION OPS, TIME * .. * * Purpose * ======= * * DMFLOP computes the megaflop rate given the number of operations * and time in seconds. This is basically just a divide operation, * but care is taken not to divide by zero. * * Arguments * ========= * * OPS (input) DOUBLE PRECISION * The number of floating point operations. * performed by the timed routine. * * TIME (input) DOUBLE PRECISION * The total time in seconds. * * INFO (input) INTEGER * The return code from the timed routine. If INFO is not 0, * then DMFLOP returns a negative value, indicating an error. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE * .. * .. Executable Statements .. * IF( TIME.LE.ZERO ) THEN DMFLOP = ZERO ELSE DMFLOP = OPS / ( 1.0D6*TIME ) END IF IF( INFO.NE.0 ) $ DMFLOP = -ABS( DBLE( INFO ) ) RETURN * * End of DMFLOP * END SHAR_EOF fi # end of overwriting check if test -f 'dopbl2.f' then echo shar: will not over-write existing file "'dopbl2.f'" else cat << SHAR_EOF > 'dopbl2.f' DOUBLE PRECISION FUNCTION DOPBL2( SUBNAM, M, N, KKL, KKU ) * * -- LAPACK timing routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER*6 SUBNAM INTEGER KKL, KKU, M, N * .. * * Purpose * ======= * * DOPBL2 computes an approximation of the number of floating point * operations used by a subroutine SUBNAM with the given values * of the parameters M, N, KL, and KU. * * This version counts operations for the Level 2 BLAS. * * Arguments * ========= * * SUBNAM (input) CHARACTER*6 * The name of the subroutine. * * M (input) INTEGER * The number of rows of the coefficient matrix. M >= 0. * * N (input) INTEGER * The number of columns of the coefficient matrix. * If the matrix is square (such as in a solve routine) then * N is the number of right hand sides. N >= 0. * * KKL (input) INTEGER * The lower band width of the coefficient matrix. * KL is set to max( 0, min( M-1, KKL ) ). * * KKU (input) INTEGER * The upper band width of the coefficient matrix. * KU is set to max( 0, min( N-1, KKU ) ). * * ===================================================================== * * .. Local Scalars .. CHARACTER C1 CHARACTER*2 C2 CHARACTER*3 C3 DOUBLE PRECISION ADDS, EK, EM, EN, KL, KU, MULTS * .. * .. External Functions .. LOGICAL LSAME, LSAMEN EXTERNAL LSAME, LSAMEN * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Quick return if possible * IF( M.LE.0 .OR. .NOT.( LSAME( SUBNAM, 'S' ) .OR. LSAME( SUBNAM, $ 'D' ) .OR. LSAME( SUBNAM, 'C' ) .OR. LSAME( SUBNAM, 'Z' ) ) ) $ THEN DOPBL2 = 0 RETURN END IF * C1 = SUBNAM( 1: 1 ) C2 = SUBNAM( 2: 3 ) C3 = SUBNAM( 4: 6 ) MULTS = 0 ADDS = 0 KL = MAX( 0, MIN( M-1, KKL ) ) KU = MAX( 0, MIN( N-1, KKU ) ) EM = M EN = N EK = KL * * ------------------------------- * Matrix-vector multiply routines * ------------------------------- * IF( LSAMEN( 3, C3, 'MV ' ) ) THEN * IF( LSAMEN( 2, C2, 'GE' ) ) THEN * MULTS = EM*( EN+1.D0 ) ADDS = EM*EN * * Assume M <= N + KL and KL < M * N <= M + KU and KU < N * so that the zero sections are triangles. * ELSE IF( LSAMEN( 2, C2, 'GB' ) ) THEN * MULTS = EM*( EN+1.D0 ) - ( EM-1.D0-KL )*( EM-KL ) / 2.D0 - $ ( EN-1.D0-KU )*( EN-KU ) / 2.D0 ADDS = EM*( EN+1.D0 ) - ( EM-1.D0-KL )*( EM-KL ) / 2.D0 - $ ( EN-1.D0-KU )*( EN-KU ) / 2.D0 * ELSE IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 2, C2, 'SP' ) .OR. $ LSAMEN( 3, SUBNAM, 'ZHE' ) .OR. $ LSAMEN( 3, SUBNAM, 'ZHE' ) .OR. $ LSAMEN( 3, SUBNAM, 'ZHP' ) .OR. $ LSAMEN( 3, SUBNAM, 'ZHP' ) ) THEN * MULTS = EM*( EM+1.D0 ) ADDS = EM*EM * ELSE IF( LSAMEN( 2, C2, 'SB' ) .OR. $ LSAMEN( 3, SUBNAM, 'ZHB' ) .OR. $ LSAMEN( 3, SUBNAM, 'ZHB' ) ) THEN * MULTS = EM*( EM+1.D0 ) - ( EM-1.D0-EK )*( EM-EK ) ADDS = EM*EM - ( EM-1.D0-EK )*( EM-EK ) * ELSE IF( LSAMEN( 2, C2, 'TR' ) .OR. LSAMEN( 2, C2, 'TP' ) ) $ THEN * MULTS = EM*( EM+1.D0 ) / 2.D0 ADDS = ( EM-1.D0 )*EM / 2.D0 * ELSE IF( LSAMEN( 2, C2, 'TB' ) ) THEN * MULTS = EM*( EM+1.D0 ) / 2.D0 - $ ( EM-EK-1.D0 )*( EM-EK ) / 2.D0 ADDS = ( EM-1.D0 )*EM / 2.D0 - $ ( EM-EK-1.D0 )*( EM-EK ) / 2.D0 * END IF * * --------------------- * Matrix solve routines * --------------------- * ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN * IF( LSAMEN( 2, C2, 'TR' ) .OR. LSAMEN( 2, C2, 'TP' ) ) THEN * MULTS = EM*( EM+1.D0 ) / 2.D0 ADDS = ( EM-1.D0 )*EM / 2.D0 * ELSE IF( LSAMEN( 2, C2, 'TB' ) ) THEN * MULTS = EM*( EM+1.D0 ) / 2.D0 - $ ( EM-EK-1.D0 )*( EM-EK ) / 2.D0 ADDS = ( EM-1.D0 )*EM / 2.D0 - $ ( EM-EK-1.D0 )*( EM-EK ) / 2.D0 * END IF * * ---------------- * Rank-one updates * ---------------- * ELSE IF( LSAMEN( 3, C3, 'R ' ) ) THEN * IF( LSAMEN( 3, SUBNAM, 'DGE' ) .OR. $ LSAMEN( 3, SUBNAM, 'DGE' ) ) THEN * MULTS = EM*EN + MIN( EM, EN ) ADDS = EM*EN * ELSE IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 2, C2, 'SP' ) .OR. $ LSAMEN( 3, SUBNAM, 'ZHE' ) .OR. $ LSAMEN( 3, SUBNAM, 'ZHP' ) .OR. $ LSAMEN( 3, SUBNAM, 'ZHE' ) .OR. $ LSAMEN( 3, SUBNAM, 'ZHP' ) ) THEN * MULTS = EM*( EM+1.D0 ) / 2.D0 + EM ADDS = EM*( EM+1.D0 ) / 2.D0 * END IF * ELSE IF( LSAMEN( 3, C3, 'RC ' ) .OR. LSAMEN( 3, C3, 'RU ' ) ) THEN * IF( LSAMEN( 3, SUBNAM, 'ZGE' ) .OR. $ LSAMEN( 3, SUBNAM, 'ZGE' ) ) THEN * MULTS = EM*EN + MIN( EM, EN ) ADDS = EM*EN * END IF * * ---------------- * Rank-two updates * ---------------- * ELSE IF( LSAMEN( 3, C3, 'R2 ' ) ) THEN IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 2, C2, 'SP' ) .OR. $ LSAMEN( 3, SUBNAM, 'ZHE' ) .OR. $ LSAMEN( 3, SUBNAM, 'ZHP' ) .OR. $ LSAMEN( 3, SUBNAM, 'ZHE' ) .OR. $ LSAMEN( 3, SUBNAM, 'ZHP' ) ) THEN * MULTS = EM*( EM+1.D0 ) + 2.D0*EM ADDS = EM*( EM+1.D0 ) * END IF END IF * * ------------------------------------------------ * Compute the total number of operations. * For real and double precision routines, count * 1 for each multiply and 1 for each add. * For complex and complex*16 routines, count * 6 for each multiply and 2 for each add. * ------------------------------------------------ * IF( LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' ) ) THEN * DOPBL2 = MULTS + ADDS * ELSE * DOPBL2 = 6*MULTS + 2*ADDS * END IF * RETURN * * End of DOPBL2 * END SHAR_EOF fi # end of overwriting check if test -f 'dopbl3.f' then echo shar: will not over-write existing file "'dopbl3.f'" else cat << SHAR_EOF > 'dopbl3.f' DOUBLE PRECISION FUNCTION DOPBL3( SUBNAM, M, N, K ) * * -- LAPACK timing routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER*6 SUBNAM INTEGER K, M, N * .. * * Purpose * ======= * * DOPBL3 computes an approximation of the number of floating point * operations used by a subroutine SUBNAM with the given values * of the parameters M, N, and K. * * This version counts operations for the Level 3 BLAS. * * Arguments * ========= * * SUBNAM (input) CHARACTER*6 * The name of the subroutine. * * M (input) INTEGER * N (input) INTEGER * K (input) INTEGER * M, N, and K contain parameter values used by the Level 3 * BLAS. The output matrix is always M x N or N x N if * symmetric, but K has different uses in different * contexts. For example, in the matrix-matrix multiply * routine, we have * C = A * B * where C is M x N, A is M x K, and B is K x N. * In xSYMM, xTRMM, and xTRSM, K indicates whether the matrix * A is applied on the left or right. If K <= 0, the matrix * is applied on the left, if K > 0, on the right. * * ===================================================================== * * .. Local Scalars .. CHARACTER C1 CHARACTER*2 C2 CHARACTER*3 C3 DOUBLE PRECISION ADDS, EK, EM, EN, MULTS * .. * .. External Functions .. LOGICAL LSAME, LSAMEN EXTERNAL LSAME, LSAMEN * .. * .. Executable Statements .. * * Quick return if possible * IF( M.LE.0 .OR. .NOT.( LSAME( SUBNAM, 'S' ) .OR. LSAME( SUBNAM, $ 'D' ) .OR. LSAME( SUBNAM, 'C' ) .OR. LSAME( SUBNAM, 'Z' ) ) ) $ THEN DOPBL3 = 0 RETURN END IF * C1 = SUBNAM( 1: 1 ) C2 = SUBNAM( 2: 3 ) C3 = SUBNAM( 4: 6 ) MULTS = 0 ADDS = 0 EM = M EN = N EK = K * * ---------------------- * Matrix-matrix products * assume beta = 1 * ---------------------- * IF( LSAMEN( 3, C3, 'MM ' ) ) THEN * IF( LSAMEN( 2, C2, 'GE' ) ) THEN * MULTS = EM*EK*EN ADDS = EM*EK*EN * ELSE IF( LSAMEN( 2, C2, 'SY' ) .OR. $ LSAMEN( 3, SUBNAM, 'ZHE' ) .OR. $ LSAMEN( 3, SUBNAM, 'ZHE' ) ) THEN * * IF K <= 0, assume A multiplies B on the left. * IF( K.LE.0 ) THEN MULTS = EM*EM*EN ADDS = EM*EM*EN ELSE MULTS = EM*EN*EN ADDS = EM*EN*EN END IF * ELSE IF( LSAMEN( 2, C2, 'TR' ) ) THEN * IF( K.LE.0 ) THEN MULTS = EN*EM*( EM+1.D0 ) / 2.D0 ADDS = EN*EM*( EM-1.D0 ) / 2.D0 ELSE MULTS = EM*EN*( EN+1.D0 ) / 2.D0 ADDS = EM*EN*( EN-1.D0 ) / 2.D0 END IF * END IF * * ------------------------------------------------ * Rank-K update of a symmetric or Hermitian matrix * ------------------------------------------------ * ELSE IF( LSAMEN( 3, C3, 'RK ' ) ) THEN * IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 3, SUBNAM, 'ZHE' ) .OR. $ LSAMEN( 3, SUBNAM, 'ZHE' ) ) THEN * MULTS = EK*EM*( EM+1.D0 ) / 2.D0 ADDS = EK*EM*( EM+1.D0 ) / 2.D0 END IF * * ------------------------------------------------ * Rank-2K update of a symmetric or Hermitian matrix * ------------------------------------------------ * ELSE IF( LSAMEN( 3, C3, 'R2K' ) ) THEN * IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 3, SUBNAM, 'ZHE' ) .OR. $ LSAMEN( 3, SUBNAM, 'ZHE' ) ) THEN * MULTS = EK*EM*EM ADDS = EK*EM*EM + EM END IF * * ----------------------------------------- * Solving system with many right hand sides * ----------------------------------------- * ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'TRSM ' ) ) THEN * IF( K.LE.0 ) THEN MULTS = EN*EM*( EM+1.D0 ) / 2.D0 ADDS = EN*EM*( EM-1.D0 ) / 2.D0 ELSE MULTS = EM*EN*( EN+1.D0 ) / 2.D0 ADDS = EM*EN*( EN-1.D0 ) / 2.D0 END IF * END IF * * ------------------------------------------------ * Compute the total number of operations. * For real and double precision routines, count * 1 for each multiply and 1 for each add. * For complex and complex*16 routines, count * 6 for each multiply and 2 for each add. * ------------------------------------------------ * IF( LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' ) ) THEN * DOPBL3 = MULTS + ADDS * ELSE * DOPBL3 = 6*MULTS + 2*ADDS * END IF * RETURN * * End of DOPBL3 * END SHAR_EOF fi # end of overwriting check if test -f 'dopla.f' then echo shar: will not over-write existing file "'dopla.f'" else cat << SHAR_EOF > 'dopla.f' DOUBLE PRECISION FUNCTION DOPLA( SUBNAM, M, N, KL, KU, NB ) * * -- LAPACK timing routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER*6 SUBNAM INTEGER KL, KU, M, N, NB * .. * * Purpose * ======= * * DOPLA computes an approximation of the number of floating point * operations used by the subroutine SUBNAM with the given values * of the parameters M, N, KL, KU, and NB. * * This version counts operations for the LAPACK subroutines. * * Arguments * ========= * * SUBNAM (input) CHARACTER*6 * The name of the subroutine. * * M (input) INTEGER * The number of rows of the coefficient matrix. M >= 0. * * N (input) INTEGER * The number of columns of the coefficient matrix. * For solve routine when the matrix is square, * N is the number of right hand sides. N >= 0. * * KL (input) INTEGER * The lower band width of the coefficient matrix. * If needed, 0 <= KL <= M-1. * For xGEQRS, KL is the number of right hand sides. * * KU (input) INTEGER * The upper band width of the coefficient matrix. * If needed, 0 <= KU <= N-1. * * NB (input) INTEGER * The block size. If needed, NB >= 1. * * Notes * ===== * * In the comments below, the association is given between arguments * in the requested subroutine and local arguments. For example, * * xGETRS: N, NRHS => M, N * * means that arguments N and NRHS in DGETRS are passed to arguments * M and N in this procedure. * * ===================================================================== * * .. Local Scalars .. LOGICAL CORZ, SORD CHARACTER C1 CHARACTER*2 C2 CHARACTER*3 C3 INTEGER I DOUBLE PRECISION ADDFAC, ADDS, EK, EM, EMN, EN, MULFAC, MULTS, $ WL, WU * .. * .. External Functions .. LOGICAL LSAME, LSAMEN EXTERNAL LSAME, LSAMEN * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * -------------------------------------------------------- * Initialize DOPLA to 0 and do a quick return if possible. * -------------------------------------------------------- * DOPLA = 0 MULTS = 0 ADDS = 0 C1 = SUBNAM( 1: 1 ) C2 = SUBNAM( 2: 3 ) C3 = SUBNAM( 4: 6 ) SORD = LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' ) CORZ = LSAME( C1, 'C' ) .OR. LSAME( C1, 'Z' ) IF( M.LE.0 .OR. .NOT.( SORD .OR. CORZ ) ) $ RETURN * * --------------------------------------------------------- * If the coefficient matrix is real, count each add as 1 * operation and each multiply as 1 operation. * If the coefficient matrix is complex, count each add as 2 * operations and each multiply as 6 operations. * --------------------------------------------------------- * IF( LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' ) ) THEN ADDFAC = 1 MULFAC = 1 ELSE ADDFAC = 2 MULFAC = 6 END IF EM = M EN = N EK = KL * * --------------------------------- * GE: GEneral rectangular matrices * --------------------------------- * IF( LSAMEN( 2, C2, 'GE' ) ) THEN * * xGETRF: M, N => M, N * IF( LSAMEN( 3, C3, 'TRF' ) ) THEN EMN = MIN( M, N ) ADDS = EMN*( EM*EN-( EM+EN )*( EMN+1.D0 ) / 2.D0+ $ ( EMN+1.D0 )*( 2.D0*EMN+1.D0 ) / 6.D0 ) MULTS = ADDS + EMN*( EM-( EMN+1.D0 ) / 2.D0 ) * * xGETRS: N, NRHS => M, N * ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN MULTS = EN*EM*EM ADDS = EN*( EM*( EM-1.D0 ) ) * * xGETRI: N => M * ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN MULTS = EM*( 5.D0 / 6.D0+EM*( 1.D0 / 2.D0+EM*( 2.D0 / $ 3.D0 ) ) ) ADDS = EM*( 5.D0 / 6.D0+EM*( -3.D0 / 2.D0+EM*( 2.D0 / $ 3.D0 ) ) ) * * xGEQRF or xGEQLF: M, N => M, N * ELSE IF( LSAMEN( 3, C3, 'QRF' ) .OR. $ LSAMEN( 3, C3, 'QR2' ) .OR. $ LSAMEN( 3, C3, 'QLF' ) .OR. LSAMEN( 3, C3, 'QL2' ) ) $ THEN IF( M.GE.N ) THEN MULTS = EN*( ( ( 23.D0 / 6.D0 )+EM+EN / 2.D0 )+EN* $ ( EM-EN / 3.D0 ) ) ADDS = EN*( ( 5.D0 / 6.D0 )+EN* $ ( 1.D0 / 2.D0+( EM-EN / 3.D0 ) ) ) ELSE MULTS = EM*( ( ( 23.D0 / 6.D0 )+2.D0*EN-EM / 2.D0 )+EM* $ ( EN-EM / 3.D0 ) ) ADDS = EM*( ( 5.D0 / 6.D0 )+EN-EM / 2.D0+EM* $ ( EN-EM / 3.D0 ) ) END IF * * xGERQF or xGELQF: M, N => M, N * ELSE IF( LSAMEN( 3, C3, 'RQF' ) .OR. $ LSAMEN( 3, C3, 'RQ2' ) .OR. $ LSAMEN( 3, C3, 'LQF' ) .OR. LSAMEN( 3, C3, 'LQ2' ) ) $ THEN IF( M.GE.N ) THEN MULTS = EN*( ( ( 29.D0 / 6.D0 )+EM+EN / 2.D0 )+EN* $ ( EM-EN / 3.D0 ) ) ADDS = EN*( ( 5.D0 / 6.D0 )+EM+EN* $ ( -1.D0 / 2.D0+( EM-EN / 3.D0 ) ) ) ELSE MULTS = EM*( ( ( 29.D0 / 6.D0 )+2.D0*EN-EM / 2.D0 )+EM* $ ( EN-EM / 3.D0 ) ) ADDS = EM*( ( 5.D0 / 6.D0 )+EM / 2.D0+EM* $ ( EN-EM / 3.D0 ) ) END IF * * xGEQPF: M, N => M, N * ELSE IF( LSAMEN( 3, C3, 'QPF' ) ) THEN EMN = MIN( M, N ) MULTS = 2*EN*EN + EMN*( 3*EM+5*EN+2*EM*EN-( EMN+1 )* $ ( 4+EN+EM-( 2*EMN+1 ) / 3 ) ) ADDS = EN*EN + EMN*( 2*EM+EN+2*EM*EN-( EMN+1 )* $ ( 2+EN+EM-( 2*EMN+1 ) / 3 ) ) * * xGEQRS or xGERQS: M, N, NRHS => M, N, KL * ELSE IF( LSAMEN( 3, C3, 'QRS' ) .OR. LSAMEN( 3, C3, 'RQS' ) ) $ THEN MULTS = EK*( EN*( 2.D0-EK )+EM* $ ( 2.D0*EN+( EM+1.D0 ) / 2.D0 ) ) ADDS = EK*( EN*( 1.D0-EK )+EM* $ ( 2.D0*EN+( EM-1.D0 ) / 2.D0 ) ) * * xGELQS or xGEQLS: M, N, NRHS => M, N, KL * ELSE IF( LSAMEN( 3, C3, 'LQS' ) .OR. LSAMEN( 3, C3, 'QLS' ) ) $ THEN MULTS = EK*( EM*( 2.D0-EK )+EN* $ ( 2.D0*EM+( EN+1.D0 ) / 2.D0 ) ) ADDS = EK*( EM*( 1.D0-EK )+EN* $ ( 2.D0*EM+( EN-1.D0 ) / 2.D0 ) ) * * xGEBRD: M, N => M, N * ELSE IF( LSAMEN( 3, C3, 'BRD' ) ) THEN IF( M.GE.N ) THEN MULTS = EN*( 20.D0 / 3.D0+EN* $ ( 2.D0+( 2.D0*EM-( 2.D0 / 3.D0 )*EN ) ) ) ADDS = EN*( 5.D0 / 3.D0+( EN-EM )+EN* $ ( 2.D0*EM-( 2.D0 / 3.D0 )*EN ) ) ELSE MULTS = EM*( 20.D0 / 3.D0+EM* $ ( 2.D0+( 2.D0*EN-( 2.D0 / 3.D0 )*EM ) ) ) ADDS = EM*( 5.D0 / 3.D0+( EM-EN )+EM* $ ( 2.D0*EN-( 2.D0 / 3.D0 )*EM ) ) END IF * * xGEHRD: N => M * ELSE IF( LSAMEN( 3, C3, 'HRD' ) ) THEN IF( M.EQ.1 ) THEN MULTS = 0.D0 ADDS = 0.D0 ELSE MULTS = -13.D0 + EM*( -7.D0 / 6.D0+EM* $ ( 0.5D0+EM*( 5.D0 / 3.D0 ) ) ) ADDS = -8.D0 + EM*( -2.D0 / 3.D0+EM* $ ( -1.D0+EM*( 5.D0 / 3.D0 ) ) ) END IF * END IF * * ---------------------------- * GB: General Banded matrices * ---------------------------- * Note: The operation count is overestimated because * it is assumed that the factor U fills in to the maximum * extent, i.e., that its bandwidth goes from KU to KL + KU. * ELSE IF( LSAMEN( 2, C2, 'GB' ) ) THEN * * xGBTRF: M, N, KL, KU => M, N, KL, KU * IF( LSAMEN( 3, C3, 'TRF' ) ) THEN DO 10 I = MIN( M, N ), 1, -1 WL = MAX( 0, MIN( KL, M-I ) ) WU = MAX( 0, MIN( KL+KU, N-I ) ) MULTS = MULTS + WL*( 1.D0+WU ) ADDS = ADDS + WL*WU 10 CONTINUE * * xGBTRS: N, NRHS, KL, KU => M, N, KL, KU * ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN WL = MAX( 0, MIN( KL, M-1 ) ) WU = MAX( 0, MIN( KL+KU, M-1 ) ) MULTS = EN*( EM*( WL+1.D0+WU )-0.5D0* $ ( WL*( WL+1.D0 )+WU*( WU+1.D0 ) ) ) ADDS = EN*( EM*( WL+WU )-0.5D0* $ ( WL*( WL+1.D0 )+WU*( WU+1.D0 ) ) ) * END IF * * -------------------------------------- * PO: POsitive definite matrices * PP: Positive definite Packed matrices * -------------------------------------- * ELSE IF( LSAMEN( 2, C2, 'PO' ) .OR. LSAMEN( 2, C2, 'PP' ) ) THEN * * xPOTRF: N => M * IF( LSAMEN( 3, C3, 'TRF' ) ) THEN MULTS = EM*( 1.D0 / 3.D0+EM*( 1.D0 / 2.D0+EM*( 1.D0 / $ 6.D0 ) ) ) ADDS = ( 1.D0 / 6.D0 )*EM*( -1.D0+EM*EM ) * * xPOTRS: N, NRHS => M, N * ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN MULTS = EN*( EM*( EM+1.D0 ) ) ADDS = EN*( EM*( EM-1.D0 ) ) * * xPOTRI: N => M * ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN MULTS = EM*( 2.D0 / 3.D0+EM*( 1.D0+EM*( 1.D0 / 3.D0 ) ) ) ADDS = EM*( 1.D0 / 6.D0+EM*( -1.D0 / 2.D0+EM*( 1.D0 / $ 3.D0 ) ) ) * END IF * * ------------------------------------ * PB: Positive definite Band matrices * ------------------------------------ * ELSE IF( LSAMEN( 2, C2, 'PB' ) ) THEN * * xPBTRF: N, K => M, KL * IF( LSAMEN( 3, C3, 'TRF' ) ) THEN MULTS = EK*( -2.D0 / 3.D0+EK*( -1.D0+EK*( -1.D0 / 3.D0 ) ) ) $ + EM*( 1.D0+EK*( 3.D0 / 2.D0+EK*( 1.D0 / 2.D0 ) ) ) ADDS = EK*( -1.D0 / 6.D0+EK*( -1.D0 / 2.D0+EK*( -1.D0 / $ 3.D0 ) ) ) + EM*( EK / 2.D0*( 1.D0+EK ) ) * * xPBTRS: N, NRHS, K => M, N, KL * ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN MULTS = EN*( ( 2*EM-EK )*( EK+1.D0 ) ) ADDS = EN*( EK*( 2*EM-( EK+1.D0 ) ) ) * END IF * * ---------------------------------- * PT: Positive definite Tridiagonal * ---------------------------------- * ELSE IF( LSAMEN( 2, C2, 'PT' ) ) THEN * * xPTTRF: N => M * IF( LSAMEN( 3, C3, 'TRF' ) ) THEN MULTS = 2*( EM-1 ) ADDS = EM - 1 * * xPTTRS: N, NRHS => M, N * ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN MULTS = EN*( 3*EM-2 ) ADDS = EN*( 2*( EM-1 ) ) * * xPTSV: N, NRHS => M, N * ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN MULTS = 2*( EM-1 ) + EN*( 3*EM-2 ) ADDS = EM - 1 + EN*( 2*( EM-1 ) ) END IF * * -------------------------------------------------------- * SY: SYmmetric indefinite matrices * SP: Symmetric indefinite Packed matrices * HE: HErmitian indefinite matrices (complex only) * HP: Hermitian indefinite Packed matrices (complex only) * -------------------------------------------------------- * ELSE IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 2, C2, 'SP' ) .OR. $ LSAMEN( 3, SUBNAM, 'ZHE' ) .OR. $ LSAMEN( 3, SUBNAM, 'ZHE' ) .OR. $ LSAMEN( 3, SUBNAM, 'ZHP' ) .OR. $ LSAMEN( 3, SUBNAM, 'ZHP' ) ) THEN * * xSYTRF: N => M * IF( LSAMEN( 3, C3, 'TRF' ) ) THEN MULTS = EM*( 10.D0 / 3.D0+EM* $ ( 1.D0 / 2.D0+EM*( 1.D0 / 6.D0 ) ) ) ADDS = EM / 6.D0*( -1.D0+EM*EM ) * * xSYTRS: N, NRHS => M, N * ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN MULTS = EN*EM*EM ADDS = EN*( EM*( EM-1.D0 ) ) * * xSYTRI: N => M * ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN MULTS = EM*( 2.D0 / 3.D0+EM*EM*( 1.D0 / 3.D0 ) ) ADDS = EM*( -1.D0 / 3.D0+EM*EM*( 1.D0 / 3.D0 ) ) * * xSYTRD, xSYTD2: N => M * ELSE IF( LSAMEN( 3, C3, 'TRD' ) .OR. LSAMEN( 3, C3, 'TD2' ) ) $ THEN IF( M.EQ.1 ) THEN MULTS = 0.D0 ADDS = 0.D0 ELSE MULTS = -15.D0 + EM*( -1.D0 / 6.D0+EM* $ ( 5.D0 / 2.D0+EM*( 2.D0 / 3.D0 ) ) ) ADDS = -4.D0 + EM*( -8.D0 / 3.D0+EM* $ ( 1.D0+EM*( 2.D0 / 3.D0 ) ) ) END IF END IF * * ------------------- * Triangular matrices * ------------------- * ELSE IF( LSAMEN( 2, C2, 'TR' ) .OR. LSAMEN( 2, C2, 'TP' ) ) THEN * * xTRTRS: N, NRHS => M, N * IF( LSAMEN( 3, C3, 'TRS' ) ) THEN MULTS = EN*EM*( EM+1.D0 ) / 2.D0 ADDS = EN*EM*( EM-1.D0 ) / 2.D0 * * xTRTRI: N => M * ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN MULTS = EM*( 1.D0 / 3.D0+EM*( 1.D0 / 2.D0+EM*( 1.D0 / $ 6.D0 ) ) ) ADDS = EM*( 1.D0 / 3.D0+EM*( -1.D0 / 2.D0+EM*( 1.D0 / $ 6.D0 ) ) ) * END IF * ELSE IF( LSAMEN( 2, C2, 'TB' ) ) THEN * * xTBTRS: N, NRHS, K => M, N, KL * IF( LSAMEN( 3, C3, 'TRS' ) ) THEN MULTS = EN*( EM*( EM+1.D0 ) / 2.D0-( EM-EK-1.D0 )* $ ( EM-EK ) / 2.D0 ) ADDS = EN*( EM*( EM-1.D0 ) / 2.D0-( EM-EK-1.D0 )*( EM-EK ) / $ 2.D0 ) END IF * * -------------------- * Trapezoidal matrices * -------------------- * ELSE IF( LSAMEN( 2, C2, 'TZ' ) ) THEN * * xTZRQF: M, N => M, N * IF( LSAMEN( 3, C3, 'RQF' ) ) THEN EMN = MIN( M, N ) MULTS = 3*EM*( EN-EM+1 ) + ( 2*EN-2*EM+3 )* $ ( EM*EM-EMN*( EMN+1 ) / 2 ) ADDS = ( EN-EM+1 )*( EM+2*EM*EM-EMN*( EMN+1 ) ) END IF * * ------------------- * Orthogonal matrices * ------------------- * ELSE IF( ( SORD .AND. LSAMEN( 2, C2, 'OR' ) ) .OR. $ ( CORZ .AND. LSAMEN( 2, C2, 'UN' ) ) ) THEN * * -MQR, -MLQ, -MQL, or -MRQ: M, N, K, SIDE => M, N, KL, KU * where KU<= 0 indicates SIDE = 'L' * and KU> 0 indicates SIDE = 'R' * IF( LSAMEN( 3, C3, 'MQR' ) .OR. LSAMEN( 3, C3, 'MLQ' ) .OR. $ LSAMEN( 3, C3, 'MQL' ) .OR. LSAMEN( 3, C3, 'MRQ' ) ) THEN IF( KU.LE.0 ) THEN MULTS = EK*EN*( 2.D0*EM+2.D0-EK ) ADDS = EK*EN*( 2.D0*EM+1.D0-EK ) ELSE MULTS = EK*( EM*( 2.D0*EN-EK )+ $ ( EM+EN+( 1.D0-EK ) / 2.D0 ) ) ADDS = EK*EM*( 2.D0*EN+1.D0-EK ) END IF * * -GQR or -GQL: M, N, K => M, N, KL * ELSE IF( LSAMEN( 3, C3, 'GQR' ) .OR. LSAMEN( 3, C3, 'GQL' ) ) $ THEN MULTS = EK*( -5.D0 / 3.D0+( 2.D0*EN-EK )+ $ ( 2.D0*EM*EN+EK*( ( 2.D0 / 3.D0 )*EK-EM-EN ) ) ) ADDS = EK*( 1.D0 / 3.D0+( EN-EM )+ $ ( 2.D0*EM*EN+EK*( ( 2.D0 / 3.D0 )*EK-EM-EN ) ) ) * * -GLQ or -GRQ: M, N, K => M, N, KL * ELSE IF( LSAMEN( 3, C3, 'GLQ' ) .OR. LSAMEN( 3, C3, 'GRQ' ) ) $ THEN MULTS = EK*( -2.D0 / 3.D0+( EM+EN-EK )+ $ ( 2.D0*EM*EN+EK*( ( 2.D0 / 3.D0 )*EK-EM-EN ) ) ) ADDS = EK*( 1.D0 / 3.D0+( EM-EN )+ $ ( 2.D0*EM*EN+EK*( ( 2.D0 / 3.D0 )*EK-EM-EN ) ) ) * END IF * END IF * DOPLA = MULFAC*MULTS + ADDFAC*ADDS * RETURN * * End of DOPLA * END SHAR_EOF fi # end of overwriting check if test -f 'dprtb4.f' then echo shar: will not over-write existing file "'dprtb4.f'" else cat << SHAR_EOF > 'dprtb4.f' SUBROUTINE DPRTB4( LAB1, LABM, LABN, NK, KVAL, LVAL, NM, MVAL, $ NVAL, NLDA, RESLTS, LDR1, LDR2, NOUT ) * * -- LAPACK timing routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER*( * ) LAB1, LABM, LABN INTEGER LDR1, LDR2, NK, NLDA, NM, NOUT * .. * .. Array Arguments .. INTEGER KVAL( NK ), LVAL( NK ), MVAL( NM ), NVAL( NM ) DOUBLE PRECISION RESLTS( LDR1, LDR2, * ) * .. * * Purpose * ======= * * DPRTB4 prints a table of timing data for the timing programs. * The table has NK block rows and NM columns, with NLDA * individual rows in each block row. Each block row depends on two * parameters K and L, specified as an ordered pair in the arrays KVAL * and LVAL, and each column depends on two parameters M and N, * specified as an ordered pair in the arrays MVAL and NVAL. * * Arguments * ========= * * LAB1 (input) CHARACTER*(*) * The label for the rows. * * LABM (input) CHARACTER*(*) * The first label for the columns. * * LABN (input) CHARACTER*(*) * The second label for the columns. * * NK (input) INTEGER * The number of values of KVAL and LVAL, and also the number of * block rows of the table. Each block row depends on the pair * of parameters (K,L). * * KVAL (input) INTEGER array, dimension (NK) * The values of the parameter K. * * LVAL (input) INTEGER array, dimension (NK) * The values of the parameter L. * * NM (input) INTEGER * The number of values of MVAL and NVAL, and also the number of * columns of the table. Each column depends on the pair of * parameters (M,N). * * MVAL (input) INTEGER array, dimension (NM) * The values of the parameter M. * * NVAL (input) INTEGER array, dimension (NM) * The values of the parameter N. * * NLDA (input) INTEGER * The number of values of LDA, hence the number of rows for * each pair of values (K,L). * * RESLTS (input) DOUBLE PRECISION array, dimension (LDR1, LDR2, NLDA) * The timing results for each value of (M,N), (K,L), and LDA. * * LDR1 (input) INTEGER * The first dimension of RESLTS. LDR1 >= max(1,NK). * * LDR2 (input) INTEGER * The second dimension of RESLTS. LDR2 >= max(1,NM). * * NOUT (input) INTEGER * The unit number on which the table is to be printed. * NOUT >= 0. * * ===================================================================== * * .. Local Scalars .. INTEGER I, J, K * .. * .. Executable Statements .. * IF( NOUT.LE.0 ) $ RETURN WRITE( NOUT, FMT = 9999 )LABM, ( MVAL( I ), I = 1, NM ) WRITE( NOUT, FMT = 9999 )LABN, ( NVAL( I ), I = 1, NM ) WRITE( NOUT, FMT = 9998 )LAB1 * DO 20 I = 1, NK IF( LAB1.EQ.' ' ) THEN WRITE( NOUT, FMT = 9996 )( RESLTS( 1, J, 1 ), J = 1, NM ) ELSE WRITE( NOUT, FMT = 9997 )KVAL( I ), LVAL( I ), $ ( RESLTS( I, J, 1 ), J = 1, NM ) END IF DO 10 K = 2, NLDA WRITE( NOUT, FMT = 9996 )( RESLTS( I, J, K ), J = 1, NM ) 10 CONTINUE IF( NLDA.GT.1 ) $ WRITE( NOUT, FMT = * ) 20 CONTINUE IF( NLDA.EQ.1 ) $ WRITE( NOUT, FMT = * ) RETURN * 9999 FORMAT( 10X, A4, I7, 11I8 ) 9998 FORMAT( 1X, A11 ) 9997 FORMAT( 1X, '(', I4, ',', I4, ') ', 12F8.1 ) 9996 FORMAT( 13X, 12F8.1 ) * * End of DPRTB4 * END SHAR_EOF fi # end of overwriting check if test -f 'dprtb5.f' then echo shar: will not over-write existing file "'dprtb5.f'" else cat << SHAR_EOF > 'dprtb5.f' SUBROUTINE DPRTB5( LAB1, LABM, LABN, NK, KVAL, NM, MVAL, NVAL, $ NLDA, RESLTS, LDR1, LDR2, NOUT ) * * -- LAPACK timing routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER*( * ) LAB1, LABM, LABN INTEGER LDR1, LDR2, NK, NLDA, NM, NOUT * .. * .. Array Arguments .. INTEGER KVAL( NK ), MVAL( NM ), NVAL( NM ) DOUBLE PRECISION RESLTS( LDR1, LDR2, * ) * .. * * Purpose * ======= * * DPRTB5 prints a table of timing data for the timing programs. * The table has NK block rows and NM columns, with NLDA * individual rows in each block row. Each column depends on two * parameters M and N, specified as an ordered pair in the arrays MVAL * and NVAL. * * Arguments * ========= * * LAB1 (input) CHARACTER*(*) * The label for the rows. * * LABM (input) CHARACTER*(*) * The first label for the columns. * * LABN (input) CHARACTER*(*) * The second label for the columns. * * NK (input) INTEGER * The number of values of KVAL, and also the number of block * rows of the table. * * KVAL (input) INTEGER array, dimension (NK) * The values of LAB1 used for the data in each block row. * * NM (input) INTEGER * The number of values of MVAL and NVAL, and also the number of * columns of the table. Each column depends on the pair of * parameters (M,N). * * MVAL (input) INTEGER array, dimension (NM) * The values of the parameter M. * * NVAL (input) INTEGER array, dimension (NM) * The values of the parameter N. * * NLDA (input) INTEGER * The number of values of LDA, hence the number of rows for * each value of KVAL. * * RESLTS (input) DOUBLE PRECISION array, dimension (LDR1, LDR2, NLDA) * The timing results for each value of N, K, and LDA. * * LDR1 (input) INTEGER * The first dimension of RESLTS. LDR1 >= max(1,NK). * * LDR2 (input) INTEGER * The second dimension of RESLTS. LDR2 >= max(1,NM). * * NOUT (input) INTEGER * The unit number on which the table is to be printed. * NOUT >= 0. * * ===================================================================== * * .. Local Scalars .. INTEGER I, J, K * .. * .. Executable Statements .. * IF( NOUT.LE.0 ) $ RETURN WRITE( NOUT, FMT = 9999 )LABM, ( MVAL( I ), I = 1, NM ) WRITE( NOUT, FMT = 9999 )LABN, ( NVAL( I ), I = 1, NM ) WRITE( NOUT, FMT = 9998 )LAB1 * DO 20 I = 1, NK IF( LAB1.EQ.' ' ) THEN WRITE( NOUT, FMT = 9996 )( RESLTS( 1, J, 1 ), J = 1, NM ) ELSE WRITE( NOUT, FMT = 9997 )KVAL( I ), $ ( RESLTS( I, J, 1 ), J = 1, NM ) END IF DO 10 K = 2, NLDA WRITE( NOUT, FMT = 9996 )( RESLTS( I, J, K ), J = 1, NM ) 10 CONTINUE IF( NLDA.GT.1 ) $ WRITE( NOUT, FMT = * ) 20 CONTINUE IF( NLDA.EQ.1 ) $ WRITE( NOUT, FMT = * ) RETURN * 9999 FORMAT( 6X, A4, I6, 11I8 ) 9998 FORMAT( 3X, A4 ) 9997 FORMAT( 1X, I6, 1X, 12F8.1 ) 9996 FORMAT( 8X, 12F8.1 ) * * End of DPRTB5 * END SHAR_EOF fi # end of overwriting check if test -f 'dprtbl.f' then echo shar: will not over-write existing file "'dprtbl.f'" else cat << SHAR_EOF > 'dprtbl.f' SUBROUTINE DPRTBL( LAB1, LAB2, NK, KVAL, NN, NVAL, NLDA, RESLTS, $ LDR1, LDR2, NOUT ) * * -- LAPACK timing routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER*( * ) LAB1, LAB2 INTEGER LDR1, LDR2, NK, NLDA, NN, NOUT * .. * .. Array Arguments .. INTEGER KVAL( NK ), NVAL( NN ) DOUBLE PRECISION RESLTS( LDR1, LDR2, * ) * .. * * Purpose * ======= * * DPRTBL prints a table of timing data for the timing programs. * The table has NK block rows and NN columns, with NLDA * individual rows in each block row. * * Arguments * ========= * * LAB1 (input) CHARACTER*(*) * The label for the rows. * * LAB2 (input) CHARACTER*(*) * The label for the columns. * * NK (input) INTEGER * The number of values of KVAL, and also the number of block * rows of the table. * * KVAL (input) INTEGER array, dimension (NK) * The values of LAB1 used for the data in each block row. * * NN (input) INTEGER * The number of values of NVAL, and also the number of columns * of the table. * * NVAL (input) INTEGER array, dimension (NN) * The values of LAB2 used for the data in each column. * * NLDA (input) INTEGER * The number of values of LDA, hence the number of rows for * each value of KVAL. * * RESLTS (input) DOUBLE PRECISION array, dimension (LDR1, LDR2, NLDA) * The timing results for each value of N, K, and LDA. * * LDR1 (input) INTEGER * The first dimension of RESLTS. LDR1 >= max( 1, NK ). * * LDR2 (input) INTEGER * The second dimension of RESLTS. LDR2 >= max( 1, NN ). * * NOUT (input) INTEGER * The unit number on which the table is to be printed. * NOUT >= 0. * * ===================================================================== * * .. Local Scalars .. INTEGER I, J, K * .. * .. Executable Statements .. * IF( NOUT.LE.0 ) $ RETURN WRITE( NOUT, FMT = 9999 )LAB2, ( NVAL( I ), I = 1, NN ) WRITE( NOUT, FMT = 9998 )LAB1 * DO 20 I = 1, NK IF( LAB1.EQ.' ' ) THEN WRITE( NOUT, FMT = 9996 )( RESLTS( 1, J, 1 ), J = 1, NN ) ELSE WRITE( NOUT, FMT = 9997 )KVAL( I ), $ ( RESLTS( I, J, 1 ), J = 1, NN ) END IF DO 10 K = 2, NLDA WRITE( NOUT, FMT = 9996 )( RESLTS( I, J, K ), J = 1, NN ) 10 CONTINUE IF( NLDA.GT.1 ) $ WRITE( NOUT, FMT = * ) 20 CONTINUE IF( NLDA.EQ.1 ) $ WRITE( NOUT, FMT = * ) RETURN * 9999 FORMAT( 6X, A4, I6, 11I8 ) 9998 FORMAT( 3X, A4 ) 9997 FORMAT( 1X, I6, 1X, 12F8.1 ) 9996 FORMAT( 8X, 12F8.1 ) * * End of DPRTBL * END SHAR_EOF fi # end of overwriting check if test -f 'dtimaa.f' then echo shar: will not over-write existing file "'dtimaa.f'" else cat << SHAR_EOF > 'dtimaa.f' PROGRAM DTIMAA * * -- LAPACK timing routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * Rewritten to include the timing of rrqr code. * * Purpose * ======= * * An annotated example of a data file can be obtained by deleting the * first 3 characters from the following lines: * LAPACK timing, DOUBLE PRECISION square matrices * 5 Number of values of M * 100 200 300 400 500 Values of M (row dimension) * 5 Number of values of N * 100 200 300 400 500 Values of N (column dimension) * 2 Number of values of K * 100 400 Values of K * 5 Number of values of NB * 1 16 32 48 64 Values of NB (blocksize) * 0 48 128 128 128 Values of NX (crossover point) * 2 Number of values of LDA * 512 513 Values of LDA (leading dimension) * 0.0 Minimum time in seconds * DQR T T F * DQP T * DRR T * * The routines are timed for all combinations of applicable values of * M, N, K, NB, NX, and LDA, and for all combinations of options such as * UPLO and TRANS. For Level 2 BLAS timings, values of NB are used for * INCX. Certain subroutines, such as the QR factorization, treat the * values of M and N as ordered pairs and operate on M x N matrices. * * Internal Parameters * =================== * * NMAX INTEGER * The maximum value of M or N for square matrices. * * LDAMAX INTEGER * The maximum value of LDA. * * NMAXB INTEGER * The maximum value of N for band matrices. * * MAXVAL INTEGER * The maximum number of values that can be read in for M, N, * K, NB, or NX. * * MXNLDA INTEGER * The maximum number of values that can be read in for LDA. * * NIN INTEGER * The unit number for input. Currently set to 5 (std input). * * NOUT INTEGER * The unit number for output. Currently set to 6 (std output). * * ===================================================================== * * .. Parameters .. INTEGER NMAX, LDAMAX, NMAXB PARAMETER ( NMAX = 1001, LDAMAX = NMAX+4, NMAXB = 5000 ) INTEGER LA PARAMETER ( LA = NMAX*LDAMAX ) INTEGER MAXVAL, MXNLDA PARAMETER ( MAXVAL = 12, MXNLDA = 4 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) * .. * .. Local Scalars .. LOGICAL BLAS, LDAMOK, LDANOK, LDAOK, MOK, NOK, NXNBOK CHARACTER C1 CHARACTER*2 C2 CHARACTER*3 C3 CHARACTER*80 LINE INTEGER I, L, LDR1, LDR2, LDR3, MAXK, MAXLDA, $ MAXM, MAXN, MAXNB, MKMAX, NEED, NK, NLDA, NM, $ NN, NNB DOUBLE PRECISION S1, S2, TIMMIN * .. * .. Local Arrays .. INTEGER IWORK( 2*NMAXB ), KVAL( MAXVAL ), $ LDAVAL( MXNLDA ), MVAL( MAXVAL ), $ NBVAL( MAXVAL ), NVAL( MAXVAL ), $ NXVAL( MAXVAL ) DOUBLE PRECISION A( LA, 4 ), D( 2*NMAX, 2 ), $ RESLTS( MAXVAL, MAXVAL, 2*MXNLDA, 4*MAXVAL ) * .. * .. External Functions .. LOGICAL LSAME, LSAMEN DOUBLE PRECISION DSECND EXTERNAL LSAME, LSAMEN, DSECND * .. * .. External Subroutines .. EXTERNAL DTIMMM, DTIMMV, DTIMQP, DTIMQR, $ DTIMRR * .. * .. Scalars in Common .. INTEGER NB, NEISPK, NPROC, NSHIFT * .. * .. Common blocks .. COMMON / CENVIR / NB, NPROC, NSHIFT, NEISPK * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * S1 = DSECND( ) LDR1 = MAXVAL LDR2 = MAXVAL LDR3 = 2*MXNLDA * * Read the first line. The first four characters must be 'BLAS' * for the BLAS data file format to be used. Otherwise, the LAPACK * data file format is assumed. * READ( NIN, FMT = '( A80 )' )LINE BLAS = LSAMEN( 4, LINE, 'BLAS' ) * * Find the last non-blank and print the first line of input as the * first line of output. * DO 10 L = 80, 1, -1 IF( LINE( L: L ).NE.' ' ) $ GO TO 20 10 CONTINUE L = 1 20 CONTINUE WRITE( NOUT, FMT = '( 1X, A, / )' )LINE( 1: L ) WRITE( NOUT, FMT = 9992 ) * * Read in NM and the values for M. * READ( NIN, FMT = * )NM IF( NM.GT.MAXVAL ) THEN WRITE( NOUT, FMT = 9999 )'M', 'NM', MAXVAL NM = MAXVAL END IF READ( NIN, FMT = * )( MVAL( I ), I = 1, NM ) WRITE( NOUT, FMT = 9991 )'M: ', ( MVAL( I ), I = 1, NM ) * * Check that M <= NMAXB for all values of M. * MOK = .TRUE. MAXM = 0 DO 30 I = 1, NM MAXM = MAX( MVAL( I ), MAXM ) IF( MVAL( I ).GT.NMAXB ) THEN WRITE( NOUT, FMT = 9997 )'M', MVAL( I ), NMAXB MOK = .FALSE. END IF 30 CONTINUE IF( .NOT.MOK ) $ WRITE( NOUT, FMT = * ) * * Read in NN and the values for N. * READ( NIN, FMT = * )NN IF( NN.GT.MAXVAL ) THEN WRITE( NOUT, FMT = 9999 )'N', 'NN', MAXVAL NN = MAXVAL END IF READ( NIN, FMT = * )( NVAL( I ), I = 1, NN ) WRITE( NOUT, FMT = 9991 )'N: ', ( NVAL( I ), I = 1, NN ) * * Check that N <= NMAXB for all values of N. * NOK = .TRUE. MAXN = 0 DO 40 I = 1, NN MAXN = MAX( NVAL( I ), MAXN ) IF( NVAL( I ).GT.NMAXB ) THEN WRITE( NOUT, FMT = 9997 )'N', NVAL( I ), NMAXB NOK = .FALSE. END IF 40 CONTINUE IF( .NOT.NOK ) $ WRITE( NOUT, FMT = * ) * * Read in NK and the values for K. * READ( NIN, FMT = * )NK IF( NK.GT.MAXVAL ) THEN WRITE( NOUT, FMT = 9999 )'K', 'NK', MAXVAL NK = MAXVAL END IF READ( NIN, FMT = * )( KVAL( I ), I = 1, NK ) WRITE( NOUT, FMT = 9991 )'K: ', ( KVAL( I ), I = 1, NK ) * * Find the maximum value of K (= NRHS). * MAXK = 0 DO 50 I = 1, NK MAXK = MAX( KVAL( I ), MAXK ) 50 CONTINUE MKMAX = MAXM*MAX( 2, MAXK ) * * Read in NNB and the values for NB. For the BLAS input files, * NBVAL is used to store values for INCX and INCY. * READ( NIN, FMT = * )NNB IF( NNB.GT.MAXVAL ) THEN WRITE( NOUT, FMT = 9999 )'NB', 'NNB', MAXVAL NNB = MAXVAL END IF READ( NIN, FMT = * )( NBVAL( I ), I = 1, NNB ) * * Find the maximum value of NB. * MAXNB = 0 DO 60 I = 1, NNB MAXNB = MAX( NBVAL( I ), MAXNB ) 60 CONTINUE * IF( BLAS ) THEN WRITE( NOUT, FMT = 9991 )'INCX: ', ( NBVAL( I ), I = 1, NNB ) DO 70 I = 1, NNB NXVAL( I ) = 0 70 CONTINUE ELSE * * LAPACK data files: Read in the values for NX. * READ( NIN, FMT = * )( NXVAL( I ), I = 1, NNB ) * WRITE( NOUT, FMT = 9991 )'NB: ', ( NBVAL( I ), I = 1, NNB ) WRITE( NOUT, FMT = 9991 )'NX: ', ( NXVAL( I ), I = 1, NNB ) END IF * * Read in NLDA and the values for LDA. * READ( NIN, FMT = * )NLDA IF( NLDA.GT.MXNLDA ) THEN WRITE( NOUT, FMT = 9999 )'LDA', 'NLDA', MXNLDA NLDA = MXNLDA END IF READ( NIN, FMT = * )( LDAVAL( I ), I = 1, NLDA ) WRITE( NOUT, FMT = 9991 )'LDA: ', ( LDAVAL( I ), I = 1, NLDA ) * * Check that LDA >= 1 for all values of LDA. * LDAOK = .TRUE. MAXLDA = 0 DO 80 I = 1, NLDA MAXLDA = MAX( LDAVAL( I ), MAXLDA ) IF( LDAVAL( I ).LE.0 ) THEN WRITE( NOUT, FMT = 9998 )LDAVAL( I ) LDAOK = .FALSE. END IF 80 CONTINUE IF( .NOT.LDAOK ) $ WRITE( NOUT, FMT = * ) * * Check that MAXLDA*MAXN <= LA (for the dense routines). * LDANOK = .TRUE. NEED = MAXLDA*MAXN IF( NEED.GT.LA ) THEN WRITE( NOUT, FMT = 9995 )MAXLDA, MAXN, NEED LDANOK = .FALSE. END IF * * Check that MAXLDA*MAXM + MAXM*MAXK <= 3*LA (for band routines). * LDAMOK = .TRUE. NEED = MAXLDA*MAXM + MAXM*MAXK IF( NEED.GT.3*LA ) THEN NEED = ( NEED+2 ) / 3 WRITE( NOUT, FMT = 9994 )MAXLDA, MAXM, MAXK, NEED LDAMOK = .FALSE. END IF * * Check that MAXN*MAXNB (or MAXN*INCX) <= LA. * NXNBOK = .TRUE. NEED = MAXN*MAXNB IF( NEED.GT.LA ) THEN WRITE( NOUT, FMT = 9996 )MAXN, MAXNB, NEED NXNBOK = .FALSE. END IF * IF( .NOT.( MOK .AND. NOK .AND. LDAOK .AND. LDANOK .AND. NXNBOK ) ) $ THEN WRITE( NOUT, FMT = 9984 ) GO TO 110 END IF IF( .NOT.LDAMOK ) $ WRITE( NOUT, FMT = * ) * * Read the minimum time to time a subroutine. * WRITE( NOUT, FMT = * ) READ( NIN, FMT = * )TIMMIN WRITE( NOUT, FMT = 9993 )TIMMIN WRITE( NOUT, FMT = * ) * * Read the first input line. * READ( NIN, FMT = '(A)', END = 100 )LINE * * If the first record is the special signal 'NONE', then get the * next line but don't time DGEMV. * IF( LSAMEN( 4, LINE, 'NONE' ) ) THEN READ( NIN, FMT = '(A)', END = 100 )LINE ELSE WRITE( NOUT, FMT = 9990 ) * * Time DGEMV and DGEMM. * CALL DTIMMV( 'DGEMV ', NN, NVAL, NNB, NBVAL, NLDA, $ LDAVAL, TIMMIN, A( 1, 1 ), LA, A( 1, 2 ), $ A( 1, 3 ), RESLTS, LDR1, LDR2, NOUT ) CALL DTIMMM( 'DGEMM ', 'N', NN, NVAL, NLDA, LDAVAL, $ TIMMIN, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), $ RESLTS, LDR1, LDR2, NOUT ) END IF * * Call the appropriate timing routine for each input line. * WRITE( NOUT, FMT = 9988 ) 90 CONTINUE C1 = LINE( 1: 1 ) C2 = LINE( 2: 3 ) C3 = LINE( 4: 6 ) * * Check first character for correct precision. * IF( .NOT.LSAME( C1, 'Dprecision' ) ) THEN WRITE( NOUT, FMT = 9987 )LINE( 1: 6 ) * ELSE IF( LSAMEN( 2, C2, 'QR' ) .OR. LSAMEN( 2, C3, 'QR' ) .OR. $ LSAMEN( 2, C3( 2: 3 ), 'QR' ) ) THEN * * QR routines * CALL DTIMQR( LINE, NN, MVAL, NVAL, NK, KVAL, NNB, NBVAL, $ NXVAL, NLDA, LDAVAL, TIMMIN, A( 1, 1 ), D, $ A( 1, 2 ), A( 1, 3 ), RESLTS, LDR1, LDR2, $ LDR3, NOUT ) * ELSE IF( LSAMEN( 2, C2, 'QP' ) .OR. LSAMEN( 3, C3, 'QPF' ) ) THEN * * QR with column pivoting * CALL DTIMQP( LINE, NM, MVAL, NVAL, NLDA, LDAVAL, TIMMIN, $ A( 1, 1 ), A( 1, 2 ), D( 1, 1 ), A( 1, 3 ), IWORK, $ RESLTS, LDR1, LDR2, NOUT ) * ELSE IF( LSAMEN( 2, C2, 'RR' ) .OR. LSAMEN( 3, C3, 'RRF' ) ) THEN * * Rank-Revealing QR * CALL DTIMRR( LINE, NM, MVAL, NVAL, NK, KVAL, $ NNB, NBVAL, NXVAL, NLDA, LDAVAL, TIMMIN, $ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), A( 1, 4 ), $ IWORK, RESLTS, LDR1, LDR2, NOUT ) * ELSE * WRITE( NOUT, FMT = 9987 )LINE( 1: 6 ) END IF * * Read the next line of the input file. * READ( NIN, FMT = '(A)', END = 100 )LINE GO TO 90 * * Branch to this line when the last record is read. * 100 CONTINUE S2 = DSECND( ) WRITE( NOUT, FMT = 9986 ) WRITE( NOUT, FMT = 9985 )S2 - S1 110 CONTINUE * 9999 FORMAT( ' Too many values of ', A, ' using ', A, ' = ', I2 ) 9998 FORMAT( ' *** LDA = ', I7, ' is too small, must have ', $ 'LDA > 0.' ) 9997 FORMAT( ' *** ', A1, ' = ', I7, ' is too big: ', $ 'maximum allowed is', I7 ) 9996 FORMAT( ' *** N*NB is too big for N =', I6, ', NB =', I6, $ / ' --> Increase LA to at least ', I8 ) 9995 FORMAT( ' *** LDA*N is too big for the dense routines ', '(LDA =', $ I6, ', N =', I6, ')', / ' --> Increase LA to at least ', $ I8 ) 9994 FORMAT( ' *** (LDA+K)*M is too big for the band routines ', $ '(LDA=', I6, ', M=', I6, ', K=', I6, ')', $ / ' --> Increase LA to at least ', I8 ) 9993 FORMAT( ' The minimum time a subroutine will be timed = ', F6.3, $ ' seconds' ) 9992 FORMAT( ' The following parameter values will be used:' ) 9991 FORMAT( 4X, A7, 1X, 10I6, / 12X, 10I6 ) 9990 FORMAT( / ' ------------------------------', $ / ' >>>>> Sample BLAS <<<<<', $ / ' ------------------------------' ) 9988 FORMAT( / ' ------------------------------', $ / ' >>>>> Timing data <<<<<', $ / ' ------------------------------' ) 9987 FORMAT( 1X, A6, ': Unrecognized path or subroutine name', / ) 9986 FORMAT( ' End of tests' ) 9985 FORMAT( ' Total time used = ', F12.2, ' seconds' ) 9984 FORMAT( / ' Tests not done due to input errors' ) * * End of DTIMAA * END SHAR_EOF fi # end of overwriting check if test -f 'dtimmg.f' then echo shar: will not over-write existing file "'dtimmg.f'" else cat << SHAR_EOF > 'dtimmg.f' SUBROUTINE DTIMMG( IFLAG, M, N, A, LDA, KL, KU ) * * -- LAPACK timing 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 IFLAG, KL, KU, LDA, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ) * .. * * Purpose * ======= * * DTIMMG generates a real test matrix whose type is given by IFLAG. * All the matrices are Toeplitz (constant along a diagonal), with * random elements on each diagonal. * * Arguments * ========= * * IFLAG (input) INTEGER * The type of matrix to be generated. * = 0 or 1: General matrix * = 2 or -2: General banded matrix * = 3 or -3: Symmetric positive definite matrix * = 4 or -4: Symmetric positive definite packed * = 5 or -5: Symmetric positive definite banded * = 6 or -6: Symmetric indefinite matrix * = 7 or -7: Symmetric indefinite packed * = 8 or -8: Symmetric indefinite banded * = 9 or -9: Triangular * = 10 or -10: Triangular packed * = 11 or -11: Triangular banded * = 12: General tridiagonal * = 13 or -13: Positive definite tridiagonal * For symmetric or triangular matrices, IFLAG > 0 indicates * upper triangular storage and IFLAG < 0 indicates lower * triangular storage. * * M (input) INTEGER * The number of rows of the matrix to be generated. * * N (input) INTEGER * The number of columns of the matrix to be generated. * * A (output) DOUBLE PRECISION array, dimension (LDA,N) * The generated matrix. * * If the absolute value of IFLAG is 1, 3, or 6, the leading * M x N (or N x N) subblock is used to store the matrix. * If the matrix is symmetric, only the upper or lower triangle * of this block is referenced. * * If the absolute value of IFLAG is 4 or 7, the matrix is * symmetric and packed storage is used for the upper or lower * triangle. The triangular matrix is stored columnwise as a * inear array, and the array A is treated as a vector of * length LDA. LDA must be set to at least N*(N+1)/2. * * If the absolute value of IFLAG is 2 or 5, the matrix is * returned in band format. The columns of the matrix are * specified in the columns of A and the diagonals of the * matrix are specified in the rows of A, with the leading * diagonal in row * KL + KU + 1, if IFLAG = 2 * KU + 1, if IFLAG = 5 or -2 * 1, if IFLAG = -5 * If IFLAG = 2, the first KL rows are not used to leave room * for pivoting in DGBTRF. * * LDA (input) INTEGER * The leading dimension of A. If the generated matrix is * packed, LDA >= N*(N+1)/2, otherwise LDA >= max(1,M). * * KL (input) INTEGER * The number of subdiagonals if IFLAG = 2, 5, or -5. * * KU (input) INTEGER * The number of superdiagonals if IFLAG = 2, 5, or -5. * * ===================================================================== * * .. Local Scalars .. INTEGER I, J, JJ, JN, K, MJ, MU * .. * .. Local Arrays .. INTEGER ISEED( 4 ) * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MIN, SIGN * .. * .. External Subroutines .. EXTERNAL DCOPY, DLARNV * .. * .. Data statements .. DATA ISEED / 0, 0, 0, 1 / * .. * .. Executable Statements .. * IF( M.LE.0 .OR. N.LE.0 ) THEN RETURN * ELSE IF( IFLAG.EQ.0 .OR. IFLAG.EQ.1 ) THEN * * General matrix * * Set first column and row to random values. * CALL DLARNV( 2, ISEED, M, A( 1, 1 ) ) DO 10 J = 2, N, M MJ = MIN( M, N-J+1 ) CALL DLARNV( 2, ISEED, MJ, A( 1, J ) ) IF( MJ.GT.1 ) $ CALL DCOPY( MJ-1, A( 2, J ), 1, A( 1, J+1 ), LDA ) 10 CONTINUE * * Fill in the rest of the matrix. * DO 30 J = 2, N DO 20 I = 2, M A( I, J ) = A( I-1, J-1 ) 20 CONTINUE 30 CONTINUE * ELSE IF( IFLAG.EQ.2 .OR. IFLAG.EQ.-2 ) THEN * * General band matrix * IF( IFLAG.EQ.2 ) THEN K = KL + KU + 1 ELSE K = KU + 1 END IF CALL DLARNV( 2, ISEED, MIN( M, KL+1 ), A( K, 1 ) ) MU = MIN( N-1, KU ) CALL DLARNV( 2, ISEED, MU+1, A( K-MU, N ) ) DO 40 J = 2, N - 1 MU = MIN( J-1, KU ) CALL DCOPY( MU, A( K-MU, N ), 1, A( K-MU, J ), 1 ) CALL DCOPY( MIN( M-J+1, KL+1 ), A( K, 1 ), 1, A( K, J ), 1 ) 40 CONTINUE * ELSE IF( IFLAG.EQ.3 ) THEN * * Symmetric positive definite, upper triangle * CALL DLARNV( 2, ISEED, N-1, A( 1, N ) ) A( N, N ) = DBLE( N ) DO 50 J = N - 1, 1, -1 CALL DCOPY( J, A( N-J+1, N ), 1, A( 1, J ), 1 ) 50 CONTINUE * ELSE IF( IFLAG.EQ.-3 ) THEN * * Symmetric positive definite, lower triangle * A( 1, 1 ) = DBLE( N ) IF( N.GT.1 ) $ CALL DLARNV( 2, ISEED, N-1, A( 2, 1 ) ) DO 60 J = 2, N CALL DCOPY( N-J+1, A( 1, 1 ), 1, A( J, J ), 1 ) 60 CONTINUE * ELSE IF( IFLAG.EQ.4 ) THEN * * Symmetric positive definite packed, upper triangle * JN = ( N-1 )*N / 2 + 1 CALL DLARNV( 2, ISEED, N-1, A( JN, 1 ) ) A( JN+N-1, 1 ) = DBLE( N ) JJ = JN DO 70 J = N - 1, 1, -1 JJ = JJ - J JN = JN + 1 CALL DCOPY( J, A( JN, 1 ), 1, A( JJ, 1 ), 1 ) 70 CONTINUE * ELSE IF( IFLAG.EQ.-4 ) THEN * * Symmetric positive definite packed, lower triangle * A( 1, 1 ) = DBLE( N ) IF( N.GT.1 ) $ CALL DLARNV( 2, ISEED, N-1, A( 2, 1 ) ) JJ = N + 1 DO 80 J = 2, N CALL DCOPY( N-J+1, A( 1, 1 ), 1, A( JJ, 1 ), 1 ) JJ = JJ + N - J + 1 80 CONTINUE * ELSE IF( IFLAG.EQ.5 ) THEN * * Symmetric positive definite banded, upper triangle * K = KL MU = MIN( N-1, K ) CALL DLARNV( 2, ISEED, MU, A( K+1-MU, N ) ) A( K+1, N ) = DBLE( N ) DO 90 J = N - 1, 1, -1 MU = MIN( J, K+1 ) CALL DCOPY( MU, A( K+2-MU, N ), 1, A( K+2-MU, J ), 1 ) 90 CONTINUE * ELSE IF( IFLAG.EQ.-5 ) THEN * * Symmetric positive definite banded, lower triangle * K = KL A( 1, 1 ) = DBLE( N ) CALL DLARNV( 2, ISEED, MIN( N-1, K ), A( 2, 1 ) ) DO 100 J = 2, N CALL DCOPY( MIN( N-J+1, K+1 ), A( 1, 1 ), 1, A( 1, J ), 1 ) 100 CONTINUE * ELSE IF( IFLAG.EQ.6 ) THEN * * Symmetric indefinite, upper triangle * CALL DLARNV( 2, ISEED, N, A( 1, N ) ) DO 110 J = N - 1, 1, -1 CALL DCOPY( J, A( N-J+1, N ), 1, A( 1, J ), 1 ) 110 CONTINUE * ELSE IF( IFLAG.EQ.-6 ) THEN * * Symmetric indefinite, lower triangle * CALL DLARNV( 2, ISEED, N, A( 1, 1 ) ) DO 120 J = 2, N CALL DCOPY( N-J+1, A( 1, 1 ), 1, A( J, J ), 1 ) 120 CONTINUE * ELSE IF( IFLAG.EQ.7 ) THEN * * Symmetric indefinite packed, upper triangle * JN = ( N-1 )*N / 2 + 1 CALL DLARNV( 2, ISEED, N, A( JN, 1 ) ) JJ = JN DO 130 J = N - 1, 1, -1 JJ = JJ - J JN = JN + 1 CALL DCOPY( J, A( JN, 1 ), 1, A( JJ, 1 ), 1 ) 130 CONTINUE * ELSE IF( IFLAG.EQ.-7 ) THEN * * Symmetric indefinite packed, lower triangle * CALL DLARNV( 2, ISEED, N, A( 1, 1 ) ) JJ = N + 1 DO 140 J = 2, N CALL DCOPY( N-J+1, A( 1, 1 ), 1, A( JJ, 1 ), 1 ) JJ = JJ + N - J + 1 140 CONTINUE * ELSE IF( IFLAG.EQ.8 ) THEN * * Symmetric indefinite banded, upper triangle * K = KL MU = MIN( N, K+1 ) CALL DLARNV( 2, ISEED, MU, A( K+2-MU, N ) ) DO 150 J = N - 1, 1, -1 MU = MIN( J, K+1 ) CALL DCOPY( MU, A( K+2-MU, N ), 1, A( K+2-MU, J ), 1 ) 150 CONTINUE * ELSE IF( IFLAG.EQ.-8 ) THEN * * Symmetric indefinite banded, lower triangle * K = KL CALL DLARNV( 2, ISEED, MIN( N, K+1 ), A( 1, 1 ) ) DO 160 J = 2, N CALL DCOPY( MIN( N-J+1, K+1 ), A( 1, 1 ), 1, A( 1, J ), 1 ) 160 CONTINUE * ELSE IF( IFLAG.EQ.9 ) THEN * * Upper triangular * CALL DLARNV( 2, ISEED, N, A( 1, N ) ) A( N, N ) = SIGN( DBLE( N ), A( N, N ) ) DO 170 J = N - 1, 1, -1 CALL DCOPY( J, A( N-J+1, N ), 1, A( 1, J ), 1 ) 170 CONTINUE * ELSE IF( IFLAG.EQ.-9 ) THEN * * Lower triangular * CALL DLARNV( 2, ISEED, N, A( 1, 1 ) ) A( 1, 1 ) = SIGN( DBLE( N ), A( 1, 1 ) ) DO 180 J = 2, N CALL DCOPY( N-J+1, A( 1, 1 ), 1, A( J, J ), 1 ) 180 CONTINUE * ELSE IF( IFLAG.EQ.10 ) THEN * * Upper triangular packed * JN = ( N-1 )*N / 2 + 1 CALL DLARNV( 2, ISEED, N, A( JN, 1 ) ) A( JN+N-1, 1 ) = SIGN( DBLE( N ), A( JN+N-1, 1 ) ) JJ = JN DO 190 J = N - 1, 1, -1 JJ = JJ - J JN = JN + 1 CALL DCOPY( J, A( JN, 1 ), 1, A( JJ, 1 ), 1 ) 190 CONTINUE * ELSE IF( IFLAG.EQ.-10 ) THEN * * Lower triangular packed * CALL DLARNV( 2, ISEED, N, A( 1, 1 ) ) A( 1, 1 ) = SIGN( DBLE( N ), A( 1, 1 ) ) JJ = N + 1 DO 200 J = 2, N CALL DCOPY( N-J+1, A( 1, 1 ), 1, A( JJ, 1 ), 1 ) JJ = JJ + N - J + 1 200 CONTINUE * ELSE IF( IFLAG.EQ.11 ) THEN * * Upper triangular banded * K = KL MU = MIN( N, K+1 ) CALL DLARNV( 2, ISEED, MU, A( K+2-MU, N ) ) A( K+1, N ) = SIGN( DBLE( K+1 ), A( K+1, N ) ) DO 210 J = N - 1, 1, -1 MU = MIN( J, K+1 ) CALL DCOPY( MU, A( K+2-MU, N ), 1, A( K+2-MU, J ), 1 ) 210 CONTINUE * ELSE IF( IFLAG.EQ.-11 ) THEN * * Lower triangular banded * K = KL CALL DLARNV( 2, ISEED, MIN( N, K+1 ), A( 1, 1 ) ) A( 1, 1 ) = SIGN( DBLE( K+1 ), A( 1, 1 ) ) DO 220 J = 2, N CALL DCOPY( MIN( N-J+1, K+1 ), A( 1, 1 ), 1, A( 1, J ), 1 ) 220 CONTINUE * ELSE IF( IFLAG.EQ.12 ) THEN * * General tridiagonal * CALL DLARNV( 2, ISEED, 3*N-2, A ) * ELSE IF( IFLAG.EQ.13 .OR. IFLAG.EQ.-13 ) THEN * * Positive definite tridiagonal * DO 230 J = 1, N A( J, 1 ) = 2.0D0 230 CONTINUE CALL DLARNV( 2, ISEED, N-1, A( N+1, 1 ) ) END IF * RETURN * * End of DTIMMG * END SHAR_EOF fi # end of overwriting check if test -f 'dtimmm.f' then echo shar: will not over-write existing file "'dtimmm.f'" else cat << SHAR_EOF > 'dtimmm.f' SUBROUTINE DTIMMM( VNAME, LAB2, NN, NVAL, NLDA, LDAVAL, TIMMIN, A, $ B, C, RESLTS, LDR1, LDR2, NOUT ) * * -- LAPACK timing routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER*( * ) LAB2, VNAME INTEGER LDR1, LDR2, NLDA, NN, NOUT DOUBLE PRECISION TIMMIN * .. * .. Array Arguments .. INTEGER LDAVAL( * ), NVAL( * ) DOUBLE PRECISION A( * ), B( * ), C( * ), RESLTS( LDR1, LDR2, * ) * .. * * Purpose * ======= * * DTIMMM times DGEMM. * * Arguments * ========= * * VNAME (input) CHARACTER*(*) * The name of the Level 3 BLAS routine to be timed. * * LAB2 (input) CHARACTER*(*) * The name of the variable given in NVAL. * * NN (input) INTEGER * The number of values of N contained in the vector NVAL. * * NVAL (input) INTEGER array, dimension (NN) * The values of the matrix dimension N. * * NLDA (input) INTEGER * The number of values of LDA contained in the vector LDAVAL. * * LDAVAL (input) INTEGER array, dimension (NLDA) * The values of the leading dimension of the array A. * * TIMMIN (input) DOUBLE PRECISION * The minimum time a subroutine will be timed. * * A (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX) * where LDAMAX and NMAX are the maximum values permitted * for LDA and N. * * B (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX) * * C (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX) * * RESLTS (output) DOUBLE PRECISION array, dimension (LDR1,LDR2,NLDA) * The timing results for each subroutine over the relevant * values of N and LDA. * * LDR1 (input) INTEGER * The first dimension of RESLTS. LDR1 >= 1. * * LDR2 (input) INTEGER * The second dimension of RESLTS. LDR2 >= max(1,NN). * * NOUT (input) INTEGER * The unit number for output. * * ===================================================================== * * .. Parameters .. INTEGER NSUBS DOUBLE PRECISION ONE PARAMETER ( NSUBS = 1, ONE = 1.0D+0 ) * .. * .. Local Scalars .. CHARACTER*6 CNAME INTEGER I, IC, ICL, ILDA, IN, INFO, ISUB, LDA, N DOUBLE PRECISION OPS, S1, S2, TIME, UNTIME * .. * .. Local Arrays .. LOGICAL TIMSUB( NSUBS ) CHARACTER*6 SUBNAM( NSUBS ) INTEGER IDUMMY( 1 ) * .. * .. External Functions .. LOGICAL LSAMEN DOUBLE PRECISION DMFLOP, DOPBL3, DSECND EXTERNAL LSAMEN, DMFLOP, DOPBL3, DSECND * .. * .. External Subroutines .. EXTERNAL ATIMCK, DGEMM, DPRTBL, DTIMMG * .. * .. Intrinsic Functions .. INTRINSIC DBLE * .. * .. Data statements .. DATA SUBNAM / 'DGEMM ' / * .. * .. Executable Statements .. * CNAME = VNAME DO 10 ISUB = 1, NSUBS TIMSUB( ISUB ) = LSAMEN( 6, CNAME, SUBNAM( ISUB ) ) IF( TIMSUB( ISUB ) ) $ GO TO 20 10 CONTINUE WRITE( NOUT, FMT = 9999 )CNAME GO TO 80 20 CONTINUE * * Check that N <= LDA for the input values. * CALL ATIMCK( 2, CNAME, NN, NVAL, NLDA, LDAVAL, NOUT, INFO ) IF( INFO.GT.0 ) THEN WRITE( NOUT, FMT = 9998 )CNAME GO TO 80 END IF * DO 60 ILDA = 1, NLDA LDA = LDAVAL( ILDA ) DO 50 IN = 1, NN N = NVAL( IN ) * * Time DGEMM * CALL DTIMMG( 1, N, N, A, LDA, 0, 0 ) CALL DTIMMG( 0, N, N, B, LDA, 0, 0 ) CALL DTIMMG( 1, N, N, C, LDA, 0, 0 ) IC = 0 S1 = DSECND( ) 30 CONTINUE CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, A, $ LDA, B, LDA, ONE, C, LDA ) S2 = DSECND( ) TIME = S2 - S1 IC = IC + 1 IF( TIME.LT.TIMMIN ) THEN CALL DTIMMG( 1, N, N, C, LDA, 0, 0 ) GO TO 30 END IF * * Subtract the time used in DTIMMG. * ICL = 1 S1 = DSECND( ) 40 CONTINUE S2 = DSECND( ) UNTIME = S2 - S1 ICL = ICL + 1 IF( ICL.LE.IC ) THEN CALL DTIMMG( 1, N, N, C, LDA, 0, 0 ) GO TO 40 END IF * TIME = ( TIME-UNTIME ) / DBLE( IC ) OPS = DOPBL3( 'DGEMM ', N, N, N ) RESLTS( 1, IN, ILDA ) = DMFLOP( OPS, TIME, 0 ) 50 CONTINUE 60 CONTINUE * * Print the table of results on unit NOUT. * WRITE( NOUT, FMT = 9997 )VNAME IF( NLDA.EQ.1 ) THEN WRITE( NOUT, FMT = 9996 )LDAVAL( 1 ) ELSE DO 70 I = 1, NLDA WRITE( NOUT, FMT = 9995 )I, LDAVAL( I ) 70 CONTINUE END IF WRITE( NOUT, FMT = * ) CALL DPRTBL( ' ', LAB2, 1, IDUMMY, NN, NVAL, NLDA, RESLTS, LDR1, $ LDR2, NOUT ) * 80 CONTINUE RETURN 9999 FORMAT( 1X, A6, ': Unrecognized path or subroutine name', / ) 9998 FORMAT( 1X, A6, ' timing run not attempted', / ) 9997 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' ) 9996 FORMAT( 5X, 'with LDA = ', I5 ) 9995 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 ) * * End of DTIMMM * END SHAR_EOF fi # end of overwriting check if test -f 'dtimmv.f' then echo shar: will not over-write existing file "'dtimmv.f'" else cat << SHAR_EOF > 'dtimmv.f' SUBROUTINE DTIMMV( VNAME, NN, NVAL, NK, KVAL, NLDA, LDAVAL, $ TIMMIN, A, LB, B, C, RESLTS, LDR1, LDR2, NOUT ) * * -- LAPACK timing routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER*( * ) VNAME INTEGER LB, LDR1, LDR2, NK, NLDA, NN, NOUT DOUBLE PRECISION TIMMIN * .. * .. Array Arguments .. INTEGER KVAL( * ), LDAVAL( * ), NVAL( * ) DOUBLE PRECISION A( * ), B( * ), C( * ), RESLTS( LDR1, LDR2, * ) * .. * * Purpose * ======= * * DTIMMV times individual BLAS 2 routines. * * Arguments * ========= * * VNAME (input) CHARACTER*(*) * The name of the Level 2 BLAS routine to be timed. * * NN (input) INTEGER * The number of values of N contained in the vector NVAL. * * NVAL (input) INTEGER array, dimension (NN) * The values of the matrix dimension N. * * NK (input) INTEGER * The number of values of K contained in the vector KVAL. * * KVAL (input) INTEGER array, dimension (NK) * The values of the bandwidth K. * * NLDA (input) INTEGER * The number of values of LDA contained in the vector LDAVAL. * * LDAVAL (input) INTEGER array, dimension (NLDA) * The values of the leading dimension of the array A. * * TIMMIN (input) DOUBLE PRECISION * The minimum time a subroutine will be timed. * * A (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX) * where LDAMAX and NMAX are the maximum values permitted * for LDA and N. * * LB (input) INTEGER * The length of B and C, needed when timing DGBMV. If timing * DGEMV, LB >= LDAMAX*NMAX. * * B (workspace) DOUBLE PRECISION array, dimension (LB) * * C (workspace) DOUBLE PRECISION array, dimension (LB) * * RESLTS (output) DOUBLE PRECISION array, dimension (LDR1,LDR2,NLDA) * The timing results for each subroutine over the relevant * values of N and LDA. * * LDR1 (input) INTEGER * The first dimension of RESLTS. LDR1 >= max(1,NK). * * LDR2 (input) INTEGER * The second dimension of RESLTS. LDR2 >= max(1,NN). * * NOUT (input) INTEGER * The unit number for output. * * ===================================================================== * * .. Parameters .. INTEGER NSUBS DOUBLE PRECISION ONE PARAMETER ( NSUBS = 2, ONE = 1.0D+0 ) * .. * .. Local Scalars .. CHARACTER LAB1, LAB2 CHARACTER*6 CNAME INTEGER I, IB, IC, ICL, IK, ILDA, IN, INFO, ISUB, K, $ KL, KU, LDA, LDB, N, NRHS DOUBLE PRECISION OPS, S1, S2, TIME, UNTIME * .. * .. Local Arrays .. LOGICAL TIMSUB( NSUBS ) CHARACTER*6 SUBNAM( NSUBS ) * .. * .. External Functions .. LOGICAL LSAME, LSAMEN DOUBLE PRECISION DMFLOP, DOPBL2, DSECND EXTERNAL LSAME, LSAMEN, DMFLOP, DOPBL2, DSECND * .. * .. External Subroutines .. EXTERNAL ATIMCK, DGBMV, DGEMV, DPRTBL, DTIMMG * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN * .. * .. Data statements .. DATA SUBNAM / 'DGEMV ', 'DGBMV ' / * .. * .. Executable Statements .. * CNAME = VNAME DO 10 ISUB = 1, NSUBS TIMSUB( ISUB ) = LSAMEN( 6, CNAME, SUBNAM( ISUB ) ) IF( TIMSUB( ISUB ) ) $ GO TO 20 10 CONTINUE WRITE( NOUT, FMT = 9999 )CNAME GO TO 150 20 CONTINUE * * Check that N or K <= LDA for the input values. * IF( LSAME( CNAME( 3: 3 ), 'B' ) ) THEN CALL ATIMCK( 0, CNAME, NK, KVAL, NLDA, LDAVAL, NOUT, INFO ) LAB1 = 'M' LAB2 = 'K' ELSE CALL ATIMCK( 2, CNAME, NN, NVAL, NLDA, LDAVAL, NOUT, INFO ) LAB1 = ' ' LAB2 = 'N' END IF IF( INFO.GT.0 ) THEN WRITE( NOUT, FMT = 9998 )CNAME GO TO 150 END IF * * Print the table header on unit NOUT. * WRITE( NOUT, FMT = 9997 )VNAME IF( NLDA.EQ.1 ) THEN WRITE( NOUT, FMT = 9996 )LDAVAL( 1 ) ELSE DO 30 I = 1, NLDA WRITE( NOUT, FMT = 9995 )I, LDAVAL( I ) 30 CONTINUE END IF WRITE( NOUT, FMT = * ) * * Time DGEMV * IF( TIMSUB( 1 ) ) THEN DO 80 ILDA = 1, NLDA LDA = LDAVAL( ILDA ) DO 70 IN = 1, NN N = NVAL( IN ) NRHS = N LDB = LDA CALL DTIMMG( 1, N, N, A, LDA, 0, 0 ) CALL DTIMMG( 0, N, NRHS, B, LDB, 0, 0 ) CALL DTIMMG( 1, N, NRHS, C, LDB, 0, 0 ) IC = 0 S1 = DSECND( ) 40 CONTINUE IB = 1 DO 50 I = 1, NRHS CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, $ B( IB ), 1, ONE, C( IB ), 1 ) IB = IB + LDB 50 CONTINUE S2 = DSECND( ) TIME = S2 - S1 IC = IC + 1 IF( TIME.LT.TIMMIN ) THEN CALL DTIMMG( 1, N, NRHS, C, LDB, 0, 0 ) GO TO 40 END IF * * Subtract the time used in DTIMMG. * ICL = 1 S1 = DSECND( ) 60 CONTINUE S2 = DSECND( ) UNTIME = S2 - S1 ICL = ICL + 1 IF( ICL.LE.IC ) THEN CALL DTIMMG( 1, N, NRHS, C, LDB, 0, 0 ) GO TO 60 END IF * TIME = ( TIME-UNTIME ) / DBLE( IC ) OPS = NRHS*DOPBL2( 'DGEMV ', N, N, 0, 0 ) RESLTS( 1, IN, ILDA ) = DMFLOP( OPS, TIME, 0 ) 70 CONTINUE 80 CONTINUE * CALL DPRTBL( LAB1, LAB2, 1, NVAL, NN, NVAL, NLDA, RESLTS, LDR1, $ LDR2, NOUT ) * ELSE IF( TIMSUB( 2 ) ) THEN * * Time DGBMV * DO 140 ILDA = 1, NLDA LDA = LDAVAL( ILDA ) DO 130 IN = 1, NN N = NVAL( IN ) DO 120 IK = 1, NK K = MIN( N-1, MAX( 0, KVAL( IK ) ) ) KL = K KU = K LDB = N CALL DTIMMG( 2, N, N, A, LDA, KL, KU ) NRHS = MIN( K, LB / LDB ) CALL DTIMMG( 0, N, NRHS, B, LDB, 0, 0 ) CALL DTIMMG( 1, N, NRHS, C, LDB, 0, 0 ) IC = 0 S1 = DSECND( ) 90 CONTINUE IB = 1 DO 100 I = 1, NRHS CALL DGBMV( 'No transpose', N, N, KL, KU, ONE, $ A( KU+1 ), LDA, B( IB ), 1, ONE, $ C( IB ), 1 ) IB = IB + LDB 100 CONTINUE S2 = DSECND( ) TIME = S2 - S1 IC = IC + 1 IF( TIME.LT.TIMMIN ) THEN CALL DTIMMG( 1, N, NRHS, C, LDB, 0, 0 ) GO TO 90 END IF * * Subtract the time used in DTIMMG. * ICL = 1 S1 = DSECND( ) 110 CONTINUE S2 = DSECND( ) UNTIME = S2 - S1 ICL = ICL + 1 IF( ICL.LE.IC ) THEN CALL DTIMMG( 1, N, NRHS, C, LDB, 0, 0 ) GO TO 110 END IF * TIME = ( TIME-UNTIME ) / DBLE( IC ) OPS = NRHS*DOPBL2( 'DGBMV ', N, N, KL, KU ) RESLTS( IN, IK, ILDA ) = DMFLOP( OPS, TIME, 0 ) 120 CONTINUE 130 CONTINUE 140 CONTINUE * CALL DPRTBL( LAB1, LAB2, NN, NVAL, NK, KVAL, NLDA, RESLTS, $ LDR1, LDR2, NOUT ) END IF * 150 CONTINUE 9999 FORMAT( 1X, A6, ': Unrecognized path or subroutine name', / ) 9998 FORMAT( 1X, A6, ' timing run not attempted', / ) 9997 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' ) 9996 FORMAT( 5X, 'with LDA = ', I5 ) 9995 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 ) RETURN * * End of DTIMMV * END SHAR_EOF fi # end of overwriting check if test -f 'dtimqp.f' then echo shar: will not over-write existing file "'dtimqp.f'" else cat << SHAR_EOF > 'dtimqp.f' SUBROUTINE DTIMQP( LINE, NM, MVAL, NVAL, NLDA, LDAVAL, TIMMIN, A, $ COPYA, TAU, WORK, IWORK, RESLTS, LDR1, LDR2, $ NOUT ) * * -- LAPACK timing routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER*80 LINE INTEGER LDR1, LDR2, NLDA, NM, NOUT DOUBLE PRECISION TIMMIN * .. * .. Array Arguments .. INTEGER IWORK( * ), LDAVAL( * ), MVAL( * ), NVAL( * ) DOUBLE PRECISION A( * ), COPYA( * ), RESLTS( LDR1, LDR2, * ), $ TAU( * ), WORK( * ) * .. * * Purpose * ======= * * DTIMQP times the LAPACK routines to perform the QR factorization with * column pivoting of a DOUBLE PRECISION general matrix. * * Two matrix types may be used for timing. The number of types is * set in the parameter NMODE and the matrix types are set in the vector * MODES, using the following key: * 2. BREAK1 D(1:N-1)=1 and D(N)=1.0/COND in DLATMS * 3. GEOM D(I)=COND**(-(I-1)/(N-1)) in DLATMS * These numbers are chosen to correspond with the matrix types in the * test code. * * Arguments * ========= * * LINE (input) CHARACTER*80 * The input line that requested this routine. The first six * characters contain either the name of a subroutine or a * generic path name. The remaining characters may be used to * specify the individual routines to be timed. See ATIMIN for * a full description of the format of the input line. * * NM (input) INTEGER * The number of values of M and N contained in the vectors * MVAL and NVAL. The matrix sizes are used in pairs (M,N). * * MVAL (input) INTEGER array, dimension (NM) * The values of the matrix row dimension M. * * NVAL (input) INTEGER array, dimension (NM) * The values of the matrix column dimension N. * * NLDA (input) INTEGER * The number of values of LDA contained in the vector LDAVAL. * * LDAVAL (input) INTEGER array, dimension (NLDA) * The values of the leading dimension of the array A. * * TIMMIN (input) DOUBLE PRECISION * The minimum time a subroutine will be timed. * * A (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX) * where LDAMAX and NMAX are the maximum values of LDA and N. * * COPYA (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX) * * TAU (workspace) DOUBLE PRECISION array, dimension (min(M,N)) * * WORK (workspace) DOUBLE PRECISION array, dimension (3*NMAX) * * IWORK (workspace) INTEGER array, dimension (2*NMAX) * * RESLTS (workspace) DOUBLE PRECISION array, dimension * (LDR1,LDR2,NLDA) * The timing results for each subroutine over the relevant * values of MODE, (M,N), and LDA. * * LDR1 (input) INTEGER * The first dimension of RESLTS. LDR1 >= max(1,NM). * * LDR2 (input) INTEGER * The second dimension of RESLTS. LDR2 >= max(1,NM). * * NOUT (input) INTEGER * The unit number for output. * * ===================================================================== * * .. Parameters .. INTEGER NSUBS, NMODE PARAMETER ( NSUBS = 1, NMODE = 2 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. CHARACTER*3 PATH CHARACTER*6 CNAME INTEGER I, IC, ICL, ILDA, IM, IMODE, INFO, LDA, M, $ MINMN, MODE, N, NB DOUBLE PRECISION COND, DMAX, OPS, S1, S2, TIME, UNTIME * .. * .. Local Arrays .. LOGICAL TIMSUB( NSUBS ) CHARACTER*6 SUBNAM( NSUBS ) INTEGER ISEED( 4 ), MODES( NMODE ) * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DMFLOP, DOPLA, DSECND EXTERNAL DLAMCH, DMFLOP, DOPLA, DSECND * .. * .. External Subroutines .. EXTERNAL ATIMCK, ATIMIN, DGEQPF, DLACPY, DLATMS, DPRTB5, $ ICOPY * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MIN * .. * .. Data statements .. DATA SUBNAM / 'DGEQPF' / DATA MODES / 2, 3 / DATA ISEED / 0, 0, 0, 1 / * .. * .. Executable Statements .. * * Extract the timing request from the input line. * PATH( 1: 1 ) = 'Double precision' PATH( 2: 3 ) = 'QP' CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO ) IF( .NOT.TIMSUB( 1 ) .OR. INFO.NE.0 ) $ GO TO 90 * * Check that M <= LDA for the input values. * CNAME = LINE( 1: 6 ) CALL ATIMCK( 1, CNAME, NM, MVAL, NLDA, LDAVAL, NOUT, INFO ) IF( INFO.GT.0 ) THEN WRITE( NOUT, FMT = 9999 )CNAME GO TO 90 END IF * * Set the condition number and scaling factor for the matrices * to be generated. * DMAX = ONE COND = ONE / DLAMCH( 'Precision' ) * * Do for each pair of values (M,N): * DO 60 IM = 1, NM M = MVAL( IM ) N = NVAL( IM ) MINMN = MIN( M, N ) * * Do for each value of LDA: * DO 50 ILDA = 1, NLDA LDA = LDAVAL( ILDA ) DO 40 IMODE = 1, NMODE MODE = MODES( IMODE ) * * Generate a test matrix of size m by n using the * singular value distribution indicated by MODE. * DO 10 I = 1, N IWORK( N+I ) = 0 10 CONTINUE CALL DLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', TAU, $ MODE, COND, DMAX, M, N, 'No packing', COPYA, $ LDA, WORK, INFO ) * * DGEQPF: QR factorization with column pivoting * CALL DLACPY( 'All', M, N, COPYA, LDA, A, LDA ) CALL ICOPY( N, IWORK( N+1 ), 1, IWORK, 1 ) IC = 0 S1 = DSECND( ) 20 CONTINUE CALL DGEQPF( M, N, A, LDA, IWORK, TAU, WORK, INFO ) S2 = DSECND( ) TIME = S2 - S1 IC = IC + 1 IF( TIME.LT.TIMMIN ) THEN CALL DLACPY( 'All', M, N, COPYA, LDA, A, LDA ) CALL ICOPY( N, IWORK( N+1 ), 1, IWORK, 1 ) GO TO 20 END IF * * Subtract the time used in DLACPY and ICOPY. * ICL = 1 S1 = DSECND( ) 30 CONTINUE S2 = DSECND( ) UNTIME = S2 - S1 ICL = ICL + 1 IF( ICL.LE.IC ) THEN CALL DLACPY( 'All', M, N, COPYA, LDA, A, LDA ) CALL ICOPY( N, IWORK( N+1 ), 1, IWORK, 1 ) GO TO 30 END IF * TIME = ( TIME-UNTIME ) / DBLE( IC ) OPS = DOPLA( 'DGEQPF', M, N, 0, 0, NB ) RESLTS( IMODE, IM, ILDA ) = DMFLOP( OPS, TIME, INFO ) * 40 CONTINUE 50 CONTINUE 60 CONTINUE * * Print tables of results * WRITE( NOUT, FMT = 9998 )SUBNAM( 1 ) IF( NLDA.GT.1 ) THEN DO 70 I = 1, NLDA WRITE( NOUT, FMT = 9997 )I, LDAVAL( I ) 70 CONTINUE END IF WRITE( NOUT, FMT = * ) CALL DPRTB5( 'Type', 'M', 'N', NMODE, MODES, NM, MVAL, NVAL, NLDA, $ RESLTS, LDR1, LDR2, NOUT ) 90 CONTINUE 9999 FORMAT( 1X, A6, ' timing run not attempted', / ) 9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' ) 9997 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 ) RETURN * * End of DTIMQP * END SHAR_EOF fi # end of overwriting check if test -f 'dtimqr.f' then echo shar: will not over-write existing file "'dtimqr.f'" else cat << SHAR_EOF > 'dtimqr.f' SUBROUTINE DTIMQR( LINE, NM, MVAL, NVAL, NK, KVAL, NNB, NBVAL, $ NXVAL, NLDA, LDAVAL, TIMMIN, A, TAU, B, WORK, $ RESLTS, LDR1, LDR2, LDR3, NOUT ) * * -- LAPACK timing routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER*80 LINE INTEGER LDR1, LDR2, LDR3, NK, NLDA, NM, NNB, NOUT DOUBLE PRECISION TIMMIN * .. * .. Array Arguments .. INTEGER KVAL( * ), LDAVAL( * ), MVAL( * ), NBVAL( * ), $ NVAL( * ), NXVAL( * ) DOUBLE PRECISION A( * ), B( * ), RESLTS( LDR1, LDR2, LDR3, * ), $ TAU( * ), WORK( * ) * .. * * Purpose * ======= * * DTIMQR times the LAPACK routines to perform the QR factorization of * a DOUBLE PRECISION general matrix. * * Arguments * ========= * * LINE (input) CHARACTER*80 * The input line that requested this routine. The first six * characters contain either the name of a subroutine or a * generic path name. The remaining characters may be used to * specify the individual routines to be timed. See ATIMIN for * a full description of the format of the input line. * * NM (input) INTEGER * The number of values of M and N contained in the vectors * MVAL and NVAL. The matrix sizes are used in pairs (M,N). * * MVAL (input) INTEGER array, dimension (NM) * The values of the matrix row dimension M. * * NVAL (input) INTEGER array, dimension (NM) * The values of the matrix column dimension N. * * NK (input) INTEGER * The number of values of K in the vector KVAL. * * KVAL (input) INTEGER array, dimension (NK) * The values of the matrix dimension K, used in DORMQR. * * NNB (input) INTEGER * The number of values of NB and NX contained in the * vectors NBVAL and NXVAL. The blocking parameters are used * in pairs (NB,NX). * * NBVAL (input) INTEGER array, dimension (NNB) * The values of the blocksize NB. * * NXVAL (input) INTEGER array, dimension (NNB) * The values of the crossover point NX. * * NLDA (input) INTEGER * The number of values of LDA contained in the vector LDAVAL. * * LDAVAL (input) INTEGER array, dimension (NLDA) * The values of the leading dimension of the array A. * * TIMMIN (input) DOUBLE PRECISION * The minimum time a subroutine will be timed. * * A (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX) * where LDAMAX and NMAX are the maximum values of LDA and N. * * TAU (workspace) DOUBLE PRECISION array, dimension (min(M,N)) * * B (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX) * * WORK (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NBMAX) * where NBMAX is the maximum value of NB. * * RESLTS (workspace) DOUBLE PRECISION array, dimension * (LDR1,LDR2,LDR3,2*NK) * The timing results for each subroutine over the relevant * values of (M,N), (NB,NX), and LDA. * * LDR1 (input) INTEGER * The first dimension of RESLTS. LDR1 >= max(1,NNB). * * LDR2 (input) INTEGER * The second dimension of RESLTS. LDR2 >= max(1,NM). * * LDR3 (input) INTEGER * The third dimension of RESLTS. LDR3 >= max(1,NLDA). * * NOUT (input) INTEGER * The unit number for output. * * Internal Parameters * =================== * * MODE INTEGER * The matrix type. MODE = 3 is a geometric distribution of * eigenvalues. See DLATMS for further details. * * COND DOUBLE PRECISION * The condition number of the matrix. The singular values are * set to values from DMAX to DMAX/COND. * * DMAX DOUBLE PRECISION * The magnitude of the largest singular value. * * ===================================================================== * * .. Parameters .. INTEGER NSUBS PARAMETER ( NSUBS = 3 ) INTEGER MODE DOUBLE PRECISION COND, DMAX PARAMETER ( MODE = 3, COND = 100.0D0, DMAX = 1.0D0 ) * .. * .. Local Scalars .. CHARACTER LABM, SIDE, TRANS CHARACTER*3 PATH CHARACTER*6 CNAME INTEGER I, I4, IC, ICL, IK, ILDA, IM, IMX, INB, INFO, $ ISIDE, ISUB, ITOFF, ITRAN, K, K1, LDA, LW, M, $ M1, MINMN, N, N1, NB, NX DOUBLE PRECISION OPS, S1, S2, TIME, UNTIME * .. * .. Local Arrays .. LOGICAL TIMSUB( NSUBS ) CHARACTER SIDES( 2 ), TRANSS( 2 ) CHARACTER*6 SUBNAM( NSUBS ) INTEGER ISEED( 4 ), MUSE( 12 ), NUSE( 12 ), RESEED( 4 ) * .. * .. External Functions .. DOUBLE PRECISION DMFLOP, DOPLA, DSECND EXTERNAL DMFLOP, DOPLA, DSECND * .. * .. External Subroutines .. EXTERNAL ATIMCK, ATIMIN, DGEQRF, DLACPY, DLATMS, DORGQR, $ DORMQR, DPRTB4, DPRTB5, DTIMMG, ICOPY, XLAENV * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN * .. * .. Data statements .. DATA SUBNAM / 'DGEQRF', 'DORGQR', 'DORMQR' / DATA SIDES / 'L', 'R' / , TRANSS / 'N', 'T' / DATA ISEED / 0, 0, 0, 1 / * .. * .. Executable Statements .. * * Extract the timing request from the input line. * PATH( 1: 1 ) = 'Double precision' PATH( 2: 3 ) = 'QR' CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO ) IF( INFO.NE.0 ) $ GO TO 230 * * Check that M <= LDA for the input values. * CNAME = LINE( 1: 6 ) CALL ATIMCK( 1, CNAME, NM, MVAL, NLDA, LDAVAL, NOUT, INFO ) IF( INFO.GT.0 ) THEN WRITE( NOUT, FMT = 9999 )CNAME GO TO 230 END IF * * Do for each pair of values (M,N): * DO 70 IM = 1, NM M = MVAL( IM ) N = NVAL( IM ) MINMN = MIN( M, N ) CALL ICOPY( 4, ISEED, 1, RESEED, 1 ) * * Do for each value of LDA: * DO 60 ILDA = 1, NLDA LDA = LDAVAL( ILDA ) * * Do for each pair of values (NB, NX) in NBVAL and NXVAL. * DO 50 INB = 1, NNB NB = NBVAL( INB ) CALL XLAENV( 1, NB ) NX = NXVAL( INB ) CALL XLAENV( 3, NX ) LW = MAX( 1, N*MAX( 1, NB ) ) * * Generate a test matrix of size M by N. * CALL ICOPY( 4, RESEED, 1, ISEED, 1 ) CALL DLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', TAU, $ MODE, COND, DMAX, M, N, 'No packing', B, $ LDA, WORK, INFO ) * IF( TIMSUB( 1 ) ) THEN * * DGEQRF: QR factorization * CALL DLACPY( 'Full', M, N, B, LDA, A, LDA ) IC = 0 S1 = DSECND( ) 10 CONTINUE CALL DGEQRF( M, N, A, LDA, TAU, WORK, LW, INFO ) S2 = DSECND( ) TIME = S2 - S1 IC = IC + 1 IF( TIME.LT.TIMMIN ) THEN CALL DLACPY( 'Full', M, N, B, LDA, A, LDA ) GO TO 10 END IF * * Subtract the time used in DLACPY. * ICL = 1 S1 = DSECND( ) 20 CONTINUE S2 = DSECND( ) UNTIME = S2 - S1 ICL = ICL + 1 IF( ICL.LE.IC ) THEN CALL DLACPY( 'Full', M, N, A, LDA, B, LDA ) GO TO 20 END IF * TIME = ( TIME-UNTIME ) / DBLE( IC ) OPS = DOPLA( 'DGEQRF', M, N, 0, 0, NB ) RESLTS( INB, IM, ILDA, 1 ) = DMFLOP( OPS, TIME, INFO ) ELSE * * If DGEQRF was not timed, generate a matrix and factor * it using DGEQRF anyway so that the factored form of * the matrix can be used in timing the other routines. * CALL DLACPY( 'Full', M, N, B, LDA, A, LDA ) CALL DGEQRF( M, N, A, LDA, TAU, WORK, LW, INFO ) END IF * IF( TIMSUB( 2 ) ) THEN * * DORGQR: Generate orthogonal matrix Q from the QR * factorization * CALL DLACPY( 'Full', M, MINMN, A, LDA, B, LDA ) IC = 0 S1 = DSECND( ) 30 CONTINUE CALL DORGQR( M, MINMN, MINMN, B, LDA, TAU, WORK, LW, $ INFO ) S2 = DSECND( ) TIME = S2 - S1 IC = IC + 1 IF( TIME.LT.TIMMIN ) THEN CALL DLACPY( 'Full', M, MINMN, A, LDA, B, LDA ) GO TO 30 END IF * * Subtract the time used in DLACPY. * ICL = 1 S1 = DSECND( ) 40 CONTINUE S2 = DSECND( ) UNTIME = S2 - S1 ICL = ICL + 1 IF( ICL.LE.IC ) THEN CALL DLACPY( 'Full', M, MINMN, A, LDA, B, LDA ) GO TO 40 END IF * TIME = ( TIME-UNTIME ) / DBLE( IC ) OPS = DOPLA( 'DORGQR', M, MINMN, MINMN, 0, NB ) RESLTS( INB, IM, ILDA, 2 ) = DMFLOP( OPS, TIME, INFO ) END IF * 50 CONTINUE 60 CONTINUE 70 CONTINUE * * Print tables of results * DO 90 ISUB = 1, NSUBS - 1 IF( .NOT.TIMSUB( ISUB ) ) $ GO TO 90 WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB ) IF( NLDA.GT.1 ) THEN DO 80 I = 1, NLDA WRITE( NOUT, FMT = 9997 )I, LDAVAL( I ) 80 CONTINUE END IF WRITE( NOUT, FMT = * ) IF( ISUB.EQ.2 ) $ WRITE( NOUT, FMT = 9996 ) CALL DPRTB4( '( NB, NX)', 'M', 'N', NNB, NBVAL, NXVAL, NM, $ MVAL, NVAL, NLDA, RESLTS( 1, 1, 1, ISUB ), LDR1, $ LDR2, NOUT ) 90 CONTINUE * * Time DORMQR separately. Here the starting matrix is M by N, and * K is the free dimension of the matrix multiplied by Q. * IF( TIMSUB( 3 ) ) THEN * * Check that K <= LDA for the input values. * CALL ATIMCK( 3, CNAME, NK, KVAL, NLDA, LDAVAL, NOUT, INFO ) IF( INFO.GT.0 ) THEN WRITE( NOUT, FMT = 9999 )SUBNAM( 3 ) GO TO 230 END IF * * Use only the pairs (M,N) where M >= N. * IMX = 0 DO 100 IM = 1, NM IF( MVAL( IM ).GE.NVAL( IM ) ) THEN IMX = IMX + 1 MUSE( IMX ) = MVAL( IM ) NUSE( IMX ) = NVAL( IM ) END IF 100 CONTINUE * * DORMQR: Multiply by Q stored as a product of elementary * transformations * * Do for each pair of values (M,N): * DO 180 IM = 1, IMX M = MUSE( IM ) N = NUSE( IM ) * * Do for each value of LDA: * DO 170 ILDA = 1, NLDA LDA = LDAVAL( ILDA ) * * Generate an M by N matrix and form its QR decomposition. * CALL DLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', TAU, $ MODE, COND, DMAX, M, N, 'No packing', A, $ LDA, WORK, INFO ) LW = MAX( 1, N*MAX( 1, NB ) ) CALL DGEQRF( M, N, A, LDA, TAU, WORK, LW, INFO ) * * Do first for SIDE = 'L', then for SIDE = 'R' * I4 = 0 DO 160 ISIDE = 1, 2 SIDE = SIDES( ISIDE ) * * Do for each pair of values (NB, NX) in NBVAL and * NXVAL. * DO 150 INB = 1, NNB NB = NBVAL( INB ) CALL XLAENV( 1, NB ) NX = NXVAL( INB ) CALL XLAENV( 3, NX ) * * Do for each value of K in KVAL * DO 140 IK = 1, NK K = KVAL( IK ) * * Sort out which variable is which * IF( ISIDE.EQ.1 ) THEN M1 = M K1 = N N1 = K LW = MAX( 1, N1*MAX( 1, NB ) ) ELSE N1 = M K1 = N M1 = K LW = MAX( 1, M1*MAX( 1, NB ) ) END IF * * Do first for TRANS = 'N', then for TRANS = 'T' * ITOFF = 0 DO 130 ITRAN = 1, 2 TRANS = TRANSS( ITRAN ) CALL DTIMMG( 0, M1, N1, B, LDA, 0, 0 ) IC = 0 S1 = DSECND( ) 110 CONTINUE CALL DORMQR( SIDE, TRANS, M1, N1, K1, A, LDA, $ TAU, B, LDA, WORK, LW, INFO ) S2 = DSECND( ) TIME = S2 - S1 IC = IC + 1 IF( TIME.LT.TIMMIN ) THEN CALL DTIMMG( 0, M1, N1, B, LDA, 0, 0 ) GO TO 110 END IF * * Subtract the time used in DTIMMG. * ICL = 1 S1 = DSECND( ) 120 CONTINUE S2 = DSECND( ) UNTIME = S2 - S1 ICL = ICL + 1 IF( ICL.LE.IC ) THEN CALL DTIMMG( 0, M1, N1, B, LDA, 0, 0 ) GO TO 120 END IF * TIME = ( TIME-UNTIME ) / DBLE( IC ) OPS = DOPLA( 'DORMQR', M1, N1, K1, ISIDE-1, $ NB ) RESLTS( INB, IM, ILDA, $ I4+ITOFF+IK ) = DMFLOP( OPS, TIME, INFO ) ITOFF = NK 130 CONTINUE 140 CONTINUE 150 CONTINUE I4 = 2*NK 160 CONTINUE 170 CONTINUE 180 CONTINUE * * Print tables of results * ISUB = 3 I4 = 1 IF( IMX.GE.1 ) THEN DO 220 ISIDE = 1, 2 SIDE = SIDES( ISIDE ) IF( ISIDE.EQ.1 ) THEN WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB ) IF( NLDA.GT.1 ) THEN DO 190 I = 1, NLDA WRITE( NOUT, FMT = 9997 )I, LDAVAL( I ) 190 CONTINUE END IF END IF DO 210 ITRAN = 1, 2 TRANS = TRANSS( ITRAN ) DO 200 IK = 1, NK IF( ISIDE.EQ.1 ) THEN N = KVAL( IK ) WRITE( NOUT, FMT = 9995 )SUBNAM( ISUB ), SIDE, $ TRANS, 'N', N LABM = 'M' ELSE M = KVAL( IK ) WRITE( NOUT, FMT = 9995 )SUBNAM( ISUB ), SIDE, $ TRANS, 'M', M LABM = 'N' END IF CALL DPRTB5( 'NB', LABM, 'K', NNB, NBVAL, IMX, $ MUSE, NUSE, NLDA, $ RESLTS( 1, 1, 1, I4 ), LDR1, LDR2, $ NOUT ) I4 = I4 + 1 200 CONTINUE 210 CONTINUE 220 CONTINUE ELSE WRITE( NOUT, FMT = 9994 )SUBNAM( ISUB ) END IF END IF 230 CONTINUE 9999 FORMAT( 1X, A6, ' timing run not attempted', / ) 9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' ) 9997 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 ) 9996 FORMAT( 5X, 'K = min(M,N)', / ) 9995 FORMAT( / 5X, A6, ' with SIDE = ''', A1, ''', TRANS = ''', A1, $ ''', ', A1, ' =', I6, / ) 9994 FORMAT( ' *** No pairs (M,N) found with M >= N: ', A6, $ ' not timed' ) RETURN * * End of DTIMQR * END SHAR_EOF fi # end of overwriting check if test -f 'dtimrr.f' then echo shar: will not over-write existing file "'dtimrr.f'" else cat << SHAR_EOF > 'dtimrr.f' SUBROUTINE DTIMRR( LINE, NM, MVAL, NVAL, NK, KVAL, NNB, $ NBVAL, NXVAL, NLDA, LDAVAL, TIMMIN, $ A, COPYA, B, WORK, IWORK, RESLTS, LDR1, $ LDR2, NOUT ) * * -- LAPACK timing routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * Rewritten to time rrqr code. * * .. Scalar Arguments .. CHARACTER*80 LINE INTEGER LDR1, LDR2, NK, NLDA, NM, NNB, NOUT DOUBLE PRECISION TIMMIN * .. * .. Array Arguments .. INTEGER IWORK( * ), KVAL( * ), LDAVAL( * ), MVAL( * ), $ NBVAL( * ), NVAL( * ), NXVAL( * ) $ DOUBLE PRECISION A( * ), COPYA( * ), RESLTS( LDR1, LDR2, * ), $ B( * ), WORK( * ) * .. * * Purpose * ======= * * DTIMRR times the routines to perform the Rank-Revealing QR * factorization of a DOUBLE PRECISION general matrix. * * Two matrix types may be used for timing. The number of types is * set in the parameter NMODE and the matrix types are set in the vector * MODES, using the following key: * 2. BREAK1 D(1:N-1)=1 and D(N)=1.0/COND in DLATMS * 3. GEOM D(I)=COND**(-(I-1)/(N-1)) in DLATMS * These numbers are chosen to correspond with the matrix types in the * test code. * * Arguments * ========= * * LINE (input) CHARACTER*80 * The input line that requested this routine. The first six * characters contain either the name of a subroutine or a * generic path name. The remaining characters may be used to * specify the individual routines to be timed. See ATIMIN for * a full description of the format of the input line. * * NM (input) INTEGER * The number of values of M and N contained in the vectors * MVAL and NVAL. The matrix sizes are used in pairs (M,N). * * MVAL (input) INTEGER array, dimension (NM) * The values of the matrix row dimension M. * * NVAL (input) INTEGER array, dimension (NM) * The values of the matrix column dimension N. * * NK (input) INTEGER * The number of values of K in the vector KVAL. * * KVAL (input) INTEGER array, dimension (NK) * The values of the matrix dimension K, used in SORMQR. * * NNB (input) INTEGER * The number of values of NB and NX contained in the * vectors NBVAL and NXVAL. The blocking parameters are used * in pairs (NB,NX). * * NBVAL (input) INTEGER array, dimension (NNB) * The values of the blocksize NB. * * NXVAL (input) INTEGER array, dimension (NNB) * The values of the crossover point NX. * * NLDA (input) INTEGER * The number of values of LDA contained in the vector LDAVAL. * * LDAVAL (input) INTEGER array, dimension (NLDA) * The values of the leading dimension of the array A. * * TIMMIN (input) DOUBLE PRECISION * The minimum time a subroutine will be timed. * * A (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX) * where LDAMAX and NMAX are the maximum values of LDA and N. * * COPYA (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX) * * B (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX) * * WORK (workspace) DOUBLE PRECISION array, dimension (3*NMAX) * * IWORK (workspace) INTEGER array, dimension (NMAX) * * RESLTS (workspace) DOUBLE PRECISION array, dimension * (LDR1,LDR2,NLDA) * The timing results for each subroutine over the relevant * values of MODE, (M,N), and LDA. * * LDR1 (input) INTEGER * The first dimension of RESLTS. LDR1 >= max(1,NM). * * LDR2 (input) INTEGER * The second dimension of RESLTS. LDR2 >= max(1,NM). * * NOUT (input) INTEGER * The unit number for output. * * ===================================================================== * * .. Parameters .. INTEGER NSUBS, NMODE PARAMETER ( NSUBS = 2, NMODE = 2 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. CHARACTER*3 PATH CHARACTER*6 CNAME INTEGER I, IC, ICL, IK, ILDA, IM, IMODE, INB, INFO, $ JOB, K, LDA, LW, M, MINMN, MODE, N, NB, NX, $ RANK DOUBLE PRECISION COND, DMAX, OPS, IRCOND, ORCOND, S1, S2, $ TIME, UNTIME * .. * .. Local Arrays .. LOGICAL TIMSUB( NSUBS ) CHARACTER*6 SUBNAM( NSUBS ) INTEGER ISEED( 4 ), MODES( NMODE ) DOUBLE PRECISION SVLUES( 4 ) * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DMFLOP, DOPLA, DSECND EXTERNAL DLAMCH, DMFLOP, DOPLA, DSECND * .. * .. External Subroutines .. EXTERNAL ATIMCK, ATIMIN, DGEQPX, DGEQPY, $ DLACPY, DLATMS * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MIN * .. * .. Data statements .. DATA SUBNAM / 'DGEQPX', 'DGEQPY' / DATA MODES / 2, 3 / DATA ISEED / 0, 0, 0, 1 / * .. * .. Executable Statements .. * * Extract the timing request from the input line. * PATH( 1: 1 ) = 'Dprecision' PATH( 2: 3 ) = 'RR' CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO ) IF( .NOT.TIMSUB( 1 ) .OR. INFO.NE.0 ) $ GO TO 1000 * * Check that M <= LDA for the input values. * CNAME = LINE( 1: 6 ) CALL ATIMCK( 1, CNAME, NM, MVAL, NLDA, LDAVAL, NOUT, INFO ) IF( INFO.GT.0 ) THEN WRITE( NOUT, FMT = 9999 )CNAME GO TO 1000 END IF * * Set the condition number and scaling factor for the matrices * to be generated. * DMAX = ONE IRCOND = DLAMCH( 'Precision' ) COND = ONE / IRCOND * * Do for each value of K: * DO 10 IK = 1, NK K = KVAL( IK ) IF( K.EQ.0 ) THEN JOB = 1 ELSE JOB = 2 END IF * * Do for each type of matrix: * DO 20 IMODE = 1, NMODE MODE = MODES( IMODE ) * * * ***************** * * Timing xGEQPX * * ***************** * * Do for each value of LDA: * DO 30 ILDA = 1, NLDA LDA = LDAVAL( ILDA ) * * Do for each pair of values (M,N): * DO 40 IM = 1, NM M = MVAL( IM ) N = NVAL( IM ) MINMN = MIN( M, N ) * * Generate a test matrix of size m by n using the * singular value distribution indicated by MODE. * CALL DLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', $ B, MODE, COND, DMAX, M, N, $ 'No packing', COPYA, LDA, WORK, INFO ) * * Do for each pair of values (NB,NX) in NBVAL and NXVAL: * DO 50 INB = 1, NNB NB = NBVAL( INB ) CALL XLAENV( 1, NB ) NX = NXVAL( INB ) CALL XLAENV( 3, NX ) * IF( JOB.EQ.1 ) THEN IF( NB.LT.3 ) THEN LW = MAX( 1, 2*MINMN+3*N ) ELSE LW = MAX( 1, 2*MINMN+NB*N ) END IF ELSE IF( NB.LT.3 ) THEN LW = MAX( 1, 2*MINMN+2*N+MAX(K,N) ) ELSE LW = MAX( 1, 2*MINMN+NB*NB+NB*MAX(K,N) ) END IF END IF * * DGEQPX: Rank-Revealing QR factorization * CALL DLACPY( 'All', M, N, COPYA, LDA, A, LDA ) IC = 0 S1 = DSECND( ) 110 CONTINUE * CALL DGEQPX( JOB, M, N, K, A, LDA, B, LDA, $ IWORK, IRCOND, ORCOND, RANK, SVLUES, $ WORK, LW, INFO ) S2 = DSECND( ) * IF( INFO.NE.0 ) THEN WRITE( *,* ) '>>>Warning: INFO returned by ', $ 'DGEQPX is:', INFO INFO = 0 END IF * TIME = S2 - S1 IC = IC + 1 IF( TIME.LT.TIMMIN ) THEN CALL DLACPY( 'All', M, N, COPYA, LDA, $ A, LDA ) GO TO 110 END IF * * Subtract the time used in DLACPY. * ICL = 1 S1 = DSECND( ) 100 CONTINUE S2 = DSECND( ) UNTIME = S2 - S1 ICL = ICL + 1 IF( ICL.LE.IC ) THEN CALL DLACPY( 'All', M, N, COPYA, LDA, $ A, LDA ) GO TO 100 END IF * * The number of flops of xGEQPX is approximately the * the number of flops of xGEQPF plus the number of * flops required by xORMQR to update matrix C. * TIME = ( TIME-UNTIME ) / DBLE( IC ) * OPS = DOPLA( 'DGEQPF', M, N, 0, 0, NB ) $ + DOPLA( 'DORMQR', M, K, MINMN, 0, NB ) RESLTS( INB, IM, ILDA ) = $ DMFLOP( OPS, TIME, INFO ) * 50 CONTINUE 40 CONTINUE 30 CONTINUE * * Print the results for each value of K and type of matrix. * WRITE( NOUT, FMT = 9995 )SUBNAM( 1 ) WRITE( NOUT, FMT = 9996 )K, IMODE DO 120 I = 1, NLDA WRITE( NOUT, FMT = 9997 )I,LDAVAL( I ) 120 CONTINUE WRITE( NOUT, FMT = * ) CALL DPRTB4( '( NB, NX)', 'M', 'N', NNB, NBVAL, NXVAL, $ NM, MVAL, NVAL, NLDA, RESLTS( 1, 1, 1 ), $ LDR1, LDR2, NOUT ) * * * ***************** * * Timing xGEQPY * * ***************** * * Do for each value of LDA: * DO 200 ILDA = 1, NLDA LDA = LDAVAL( ILDA ) * * Do for each pair of values (M,N): * DO 210 IM = 1, NM M = MVAL( IM ) N = NVAL( IM ) MINMN = MIN( M, N ) * * Generate a test matrix of size m by n using the * singular value distribution indicated by MODE. * CALL DLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', $ B, MODE, COND, DMAX, M, N, $ 'No packing', COPYA, LDA, WORK, INFO ) * * Do for each pair of values (NB,NX) in NBVAL and NXVAL: * DO 220 INB = 1, NNB NB = NBVAL( INB ) CALL XLAENV( 1, NB ) NX = NXVAL( INB ) CALL XLAENV( 3, NX ) * IF( JOB.EQ.1 ) THEN IF( NB.LT.3 ) THEN LW = MAX( 1, 2*MINMN+3*N ) ELSE LW = MAX( 1, 2*MINMN+NB*N ) END IF ELSE IF( NB.LT.3 ) THEN LW = MAX( 1, 2*MINMN+2*N+MAX(K,N) ) ELSE LW = MAX( 1, 2*MINMN+NB*NB+NB*MAX(K,N) ) END IF END IF * * DGEQPY: Rank-Revealing QR factorization * CALL DLACPY( 'All', M, N, COPYA, LDA, A, LDA ) IC = 0 S1 = DSECND( ) 230 CONTINUE * CALL DGEQPY( JOB, M, N, K, A, LDA, B, LDA, $ IWORK, IRCOND, ORCOND, RANK, SVLUES, $ WORK, LW, INFO ) S2 = DSECND( ) * IF( INFO.NE.0 ) THEN WRITE( *,* ) '>>>Warning: INFO returned by ', $ 'DGEQPY is:', INFO INFO = 0 END IF * TIME = S2 - S1 IC = IC + 1 IF( TIME.LT.TIMMIN ) THEN CALL DLACPY( 'All', M, N, COPYA, LDA, $ A, LDA ) GO TO 230 END IF * * Subtract the time used in DLACPY. * ICL = 1 S1 = DSECND( ) 240 CONTINUE S2 = DSECND( ) UNTIME = S2 - S1 ICL = ICL + 1 IF( ICL.LE.IC ) THEN CALL DLACPY( 'All', M, N, COPYA, LDA, $ A, LDA ) GO TO 240 END IF * * The number of flops of xGEQPY is approximately the * the number of flops of xGEQPF plus the number of * flops required by xORMQR to update matrix C. * TIME = ( TIME-UNTIME ) / DBLE( IC ) * OPS = DOPLA( 'DGEQPF', M, N, 0, 0, NB ) $ + DOPLA( 'DORMQR', M, K, MINMN, 0, NB ) RESLTS( INB, IM, ILDA ) = $ DMFLOP( OPS, TIME, INFO ) * 220 CONTINUE 210 CONTINUE 200 CONTINUE * * Print the results for each value of K and type of matrix. * WRITE( NOUT, FMT = 9995 )SUBNAM( 2 ) WRITE( NOUT, FMT = 9996 )K, IMODE DO 250 I = 1, NLDA WRITE( NOUT, FMT = 9997 )I,LDAVAL( I ) 250 CONTINUE WRITE( NOUT, FMT = * ) CALL DPRTB4( '( NB, NX)', 'M', 'N', NNB, NBVAL, NXVAL, $ NM, MVAL, NVAL, NLDA, RESLTS( 1, 1, 1 ), $ LDR1, LDR2, NOUT ) * 20 CONTINUE 10 CONTINUE * 9995 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' ) 9996 FORMAT( 5X, 'with K = ', I4, ' and type of matrix:', I4 ) 9997 FORMAT( 5X, 'line ', I4, ' with LDA = ', I4 ) 9999 FORMAT( 1X, A6, ' timing run not attempted', / ) 1000 CONTINUE RETURN * * End of DTIMRR * END SHAR_EOF fi # end of overwriting check if test -f 'icopy.f' then echo shar: will not over-write existing file "'icopy.f'" else cat << SHAR_EOF > 'icopy.f' SUBROUTINE ICOPY( N, SX, INCX, SY, INCY ) * * -- 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 INCX, INCY, N * .. * .. Array Arguments .. INTEGER SX( * ), SY( * ) * .. * * Purpose * ======= * * ICOPY copies an integer vector x to an integer vector y. * Uses unrolled loops for increments equal to 1. * * Arguments * ========= * * N (input) INTEGER * The length of the vectors SX and SY. * * SX (input) INTEGER array, dimension (1+(N-1)*abs(INCX)) * The vector X. * * INCX (input) INTEGER * The spacing between consecutive elements of SX. * * SY (output) INTEGER array, dimension (1+(N-1)*abs(INCY)) * The vector Y. * * INCY (input) INTEGER * The spacing between consecutive elements of SY. * * ===================================================================== * * .. Local Scalars .. INTEGER I, IX, IY, M, MP1 * .. * .. Intrinsic Functions .. INTRINSIC MOD * .. * .. Executable Statements .. * IF( N.LE.0 ) $ RETURN IF( INCX.EQ.1 .AND. INCY.EQ.1 ) $ GO TO 20 * * Code for unequal increments or equal increments not equal to 1 * IX = 1 IY = 1 IF( INCX.LT.0 ) $ IX = ( -N+1 )*INCX + 1 IF( INCY.LT.0 ) $ IY = ( -N+1 )*INCY + 1 DO 10 I = 1, N SY( IY ) = SX( IX ) IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN * * Code for both increments equal to 1 * * Clean-up loop * 20 CONTINUE M = MOD( N, 7 ) IF( M.EQ.0 ) $ GO TO 40 DO 30 I = 1, M SY( I ) = SX( I ) 30 CONTINUE IF( N.LT.7 ) $ RETURN 40 CONTINUE MP1 = M + 1 DO 50 I = MP1, N, 7 SY( I ) = SX( I ) SY( I+1 ) = SX( I+1 ) SY( I+2 ) = SX( I+2 ) SY( I+3 ) = SX( I+3 ) SY( I+4 ) = SX( I+4 ) SY( I+5 ) = SX( I+5 ) SY( I+6 ) = SX( I+6 ) 50 CONTINUE RETURN * * End of ICOPY * END SHAR_EOF fi # end of overwriting check if test -f 'ilaenv.f' then echo shar: will not over-write existing file "'ilaenv.f'" else cat << SHAR_EOF > 'ilaenv.f' INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, $ N4 ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. CHARACTER*( * ) NAME, OPTS INTEGER ISPEC, N1, N2, N3, N4 * .. * * Purpose * ======= * * ILAENV returns problem-dependent parameters for the local * environment. See ISPEC for a description of the parameters. * * In this version, the problem-dependent parameters are contained in * the integer array IPARMS in the common block CLAENV and the value * with index ISPEC is copied to ILAENV. This version of ILAENV is * to be used in conjunction with XLAENV in TESTING and TIMING. * * Arguments * ========= * * ISPEC (input) INTEGER * Specifies the parameter to be returned as the value of * ILAENV. * = 1: the optimal blocksize; if this value is 1, an unblocked * algorithm will give the best performance. * = 2: the minimum block size for which the block routine * should be used; if the usable block size is less than * this value, an unblocked routine should be used. * = 3: the crossover point (in a block routine, for N less * than this value, an unblocked routine should be used) * = 4: the number of shifts, used in the nonsymmetric * eigenvalue routines * = 5: the minimum column dimension for blocking to be used; * rectangular blocks must have dimension at least k by m, * where k is given by ILAENV(2,...) and m by ILAENV(5,...) * = 6: the crossover point for the SVD (when reducing an m by n * matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds * this value, a QR factorization is used first to reduce * the matrix to a triangular form.) * = 7: the number of processors * = 8: the crossover point for the multishift QR and QZ methods * for nonsymmetric eigenvalue problems. * * Other specifications (up to 100) can be added later. * * NAME (input) CHARACTER*(*) * The name of the calling subroutine. * * OPTS (input) CHARACTER*(*) * The character options to the subroutine NAME, concatenated * into a single character string. For example, UPLO = 'U', * TRANS = 'T', and DIAG = 'N' for a triangular routine would * be specified as OPTS = 'UTN'. * * N1 (input) INTEGER * N2 (input) INTEGER * N3 (input) INTEGER * N4 (input) INTEGER * Problem dimensions for the subroutine NAME; these may not all * be required. * * (ILAENV) (output) INTEGER * >= 0: the value of the parameter specified by ISPEC * < 0: if ILAENV = -k, the k-th argument had an illegal value. * * Further Details * =============== * * The following conventions have been used when calling ILAENV from the * LAPACK routines: * 1) OPTS is a concatenation of all of the character options to * subroutine NAME, in the same order that they appear in the * argument list for NAME, even if they are not used in determining * the value of the parameter specified by ISPEC. * 2) The problem dimensions N1, N2, N3, N4 are specified in the order * that they appear in the argument list for NAME. N1 is used * first, N2 second, and so on, and unused problem dimensions are * passed a value of -1. * 3) The parameter value returned by ILAENV is checked for validity in * the calling subroutine. For example, ILAENV is used to retrieve * the optimal blocksize for STRTRI as follows: * * NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) * IF( NB.LE.1 ) NB = MAX( 1, N ) * * ===================================================================== * * .. Intrinsic Functions .. INTRINSIC INT, MIN, REAL * .. * .. Arrays in Common .. INTEGER IPARMS( 100 ) * .. * .. Common blocks .. COMMON / CLAENV / IPARMS * .. * .. Save statement .. SAVE / CLAENV / * .. * .. Executable Statements .. * IF( ISPEC.GE.1 .AND. ISPEC.LE.5 ) THEN * * Return a value from the common block. * ILAENV = IPARMS( ISPEC ) * ELSE IF( ISPEC.EQ.6 ) THEN * * Compute SVD crossover point. * ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) * ELSE IF( ISPEC.GE.7 .AND. ISPEC.LE.8 ) THEN * * Return a value from the common block. * ILAENV = IPARMS( ISPEC ) * ELSE * * Invalid value for ISPEC * ILAENV = -1 END IF * RETURN * * End of ILAENV * END SHAR_EOF fi # end of overwriting check if test -f 'smflop.f' then echo shar: will not over-write existing file "'smflop.f'" else cat << SHAR_EOF > 'smflop.f' REAL FUNCTION SMFLOP( OPS, TIME, INFO ) * * -- LAPACK timing routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. INTEGER INFO REAL OPS, TIME * .. * * Purpose * ======= * * SMFLOP computes the megaflop rate given the number of operations * and time in seconds. This is basically just a divide operation, * but care is taken not to divide by zero. * * Arguments * ========= * * OPS (input) REAL * The number of floating point operations. * performed by the timed routine. * * TIME (input) REAL * The total time in seconds. * * INFO (input) INTEGER * The return code from the timed routine. If INFO is not 0, * then SMFLOP returns a negative value, indicating an error. * * ===================================================================== * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E+0 ) * .. * .. Intrinsic Functions .. INTRINSIC ABS, REAL * .. * .. Executable Statements .. * IF( TIME.LE.ZERO ) THEN SMFLOP = ZERO ELSE SMFLOP = OPS / ( 1.0E6*TIME ) END IF IF( INFO.NE.0 ) $ SMFLOP = -ABS( REAL( INFO ) ) RETURN * * End of SMFLOP * END SHAR_EOF fi # end of overwriting check if test -f 'sopbl2.f' then echo shar: will not over-write existing file "'sopbl2.f'" else cat << SHAR_EOF > 'sopbl2.f' REAL FUNCTION SOPBL2( SUBNAM, M, N, KKL, KKU ) * * -- LAPACK timing routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER*6 SUBNAM INTEGER KKL, KKU, M, N * .. * * Purpose * ======= * * SOPBL2 computes an approximation of the number of floating point * operations used by a subroutine SUBNAM with the given values * of the parameters M, N, KL, and KU. * * This version counts operations for the Level 2 BLAS. * * Arguments * ========= * * SUBNAM (input) CHARACTER*6 * The name of the subroutine. * * M (input) INTEGER * The number of rows of the coefficient matrix. M >= 0. * * N (input) INTEGER * The number of columns of the coefficient matrix. * If the matrix is square (such as in a solve routine) then * N is the number of right hand sides. N >= 0. * * KKL (input) INTEGER * The lower band width of the coefficient matrix. * KL is set to max( 0, min( M-1, KKL ) ). * * KKU (input) INTEGER * The upper band width of the coefficient matrix. * KU is set to max( 0, min( N-1, KKU ) ). * * ===================================================================== * * .. Local Scalars .. CHARACTER C1 CHARACTER*2 C2 CHARACTER*3 C3 REAL ADDS, EK, EM, EN, KL, KU, MULTS * .. * .. External Functions .. LOGICAL LSAME, LSAMEN EXTERNAL LSAME, LSAMEN * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Quick return if possible * IF( M.LE.0 .OR. $ .NOT.( LSAME( SUBNAM, 'S' ) .OR. LSAME( SUBNAM, 'D' ) .OR. $ LSAME( SUBNAM, 'C' ) .OR. LSAME( SUBNAM, 'Z' ) ) ) THEN SOPBL2 = 0 RETURN END IF * C1 = SUBNAM( 1: 1 ) C2 = SUBNAM( 2: 3 ) C3 = SUBNAM( 4: 6 ) MULTS = 0 ADDS = 0 KL = MAX( 0, MIN( M-1, KKL ) ) KU = MAX( 0, MIN( N-1, KKU ) ) EM = M EN = N EK = KL * * ------------------------------- * Matrix-vector multiply routines * ------------------------------- * IF( LSAMEN( 3, C3, 'MV ' ) ) THEN * IF( LSAMEN( 2, C2, 'GE' ) ) THEN * MULTS = EM*( EN+1. ) ADDS = EM*EN * * Assume M <= N + KL and KL < M * N <= M + KU and KU < N * so that the zero sections are triangles. * ELSE IF( LSAMEN( 2, C2, 'GB' ) ) THEN * MULTS = EM*( EN+1. ) - ( EM-1.-KL )*( EM-KL ) / 2. - $ ( EN-1.-KU )*( EN-KU ) / 2. ADDS = EM*( EN+1. ) - ( EM-1.-KL )*( EM-KL ) / 2. - $ ( EN-1.-KU )*( EN-KU ) / 2. * ELSE IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 2, C2, 'SP' ) .OR. $ LSAMEN( 3, SUBNAM, 'CHE' ) .OR. $ LSAMEN( 3, SUBNAM, 'ZHE' ) .OR. $ LSAMEN( 3, SUBNAM, 'CHP' ) .OR. $ LSAMEN( 3, SUBNAM, 'ZHP' ) ) THEN * MULTS = EM*( EM+1. ) ADDS = EM*EM * ELSE IF( LSAMEN( 2, C2, 'SB' ) .OR. $ LSAMEN( 3, SUBNAM, 'CHB' ) .OR. $ LSAMEN( 3, SUBNAM, 'ZHB' ) ) THEN * MULTS = EM*( EM+1. ) - ( EM-1.-EK )*( EM-EK ) ADDS = EM*EM - ( EM-1.-EK )*( EM-EK ) * ELSE IF( LSAMEN( 2, C2, 'TR' ) .OR. LSAMEN( 2, C2, 'TP' ) ) $ THEN * MULTS = EM*( EM+1. ) / 2. ADDS = ( EM-1. )*EM / 2. * ELSE IF( LSAMEN( 2, C2, 'TB' ) ) THEN * MULTS = EM*( EM+1. ) / 2. - ( EM-EK-1. )*( EM-EK ) / 2. ADDS = ( EM-1. )*EM / 2. - ( EM-EK-1. )*( EM-EK ) / 2. * END IF * * --------------------- * Matrix solve routines * --------------------- * ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN * IF( LSAMEN( 2, C2, 'TR' ) .OR. LSAMEN( 2, C2, 'TP' ) ) THEN * MULTS = EM*( EM+1. ) / 2. ADDS = ( EM-1. )*EM / 2. * ELSE IF( LSAMEN( 2, C2, 'TB' ) ) THEN * MULTS = EM*( EM+1. ) / 2. - ( EM-EK-1. )*( EM-EK ) / 2. ADDS = ( EM-1. )*EM / 2. - ( EM-EK-1. )*( EM-EK ) / 2. * END IF * * ---------------- * Rank-one updates * ---------------- * ELSE IF( LSAMEN( 3, C3, 'R ' ) ) THEN * IF( LSAMEN( 3, SUBNAM, 'SGE' ) .OR. $ LSAMEN( 3, SUBNAM, 'DGE' ) ) THEN * MULTS = EM*EN + MIN( EM, EN ) ADDS = EM*EN * ELSE IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 2, C2, 'SP' ) .OR. $ LSAMEN( 3, SUBNAM, 'CHE' ) .OR. $ LSAMEN( 3, SUBNAM, 'CHP' ) .OR. $ LSAMEN( 3, SUBNAM, 'ZHE' ) .OR. $ LSAMEN( 3, SUBNAM, 'ZHP' ) ) THEN * MULTS = EM*( EM+1. ) / 2. + EM ADDS = EM*( EM+1. ) / 2. * END IF * ELSE IF( LSAMEN( 3, C3, 'RC ' ) .OR. LSAMEN( 3, C3, 'RU ' ) ) THEN * IF( LSAMEN( 3, SUBNAM, 'CGE' ) .OR. $ LSAMEN( 3, SUBNAM, 'ZGE' ) ) THEN * MULTS = EM*EN + MIN( EM, EN ) ADDS = EM*EN * END IF * * ---------------- * Rank-two updates * ---------------- * ELSE IF( LSAMEN( 3, C3, 'R2 ' ) ) THEN IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 2, C2, 'SP' ) .OR. $ LSAMEN( 3, SUBNAM, 'CHE' ) .OR. $ LSAMEN( 3, SUBNAM, 'CHP' ) .OR. $ LSAMEN( 3, SUBNAM, 'ZHE' ) .OR. $ LSAMEN( 3, SUBNAM, 'ZHP' ) ) THEN * MULTS = EM*( EM+1. ) + 2.*EM ADDS = EM*( EM+1. ) * END IF END IF * * ------------------------------------------------ * Compute the total number of operations. * For real and double precision routines, count * 1 for each multiply and 1 for each add. * For complex and complex*16 routines, count * 6 for each multiply and 2 for each add. * ------------------------------------------------ * IF( LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' ) ) THEN * SOPBL2 = MULTS + ADDS * ELSE * SOPBL2 = 6*MULTS + 2*ADDS * END IF * RETURN * * End of SOPBL2 * END SHAR_EOF fi # end of overwriting check if test -f 'sopbl3.f' then echo shar: will not over-write existing file "'sopbl3.f'" else cat << SHAR_EOF > 'sopbl3.f' REAL FUNCTION SOPBL3( SUBNAM, M, N, K ) * * -- LAPACK timing routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER*6 SUBNAM INTEGER K, M, N * .. * * Purpose * ======= * * SOPBL3 computes an approximation of the number of floating point * operations used by a subroutine SUBNAM with the given values * of the parameters M, N, and K. * * This version counts operations for the Level 3 BLAS. * * Arguments * ========= * * SUBNAM (input) CHARACTER*6 * The name of the subroutine. * * M (input) INTEGER * N (input) INTEGER * K (input) INTEGER * M, N, and K contain parameter values used by the Level 3 * BLAS. The output matrix is always M x N or N x N if * symmetric, but K has different uses in different * contexts. For example, in the matrix-matrix multiply * routine, we have * C = A * B * where C is M x N, A is M x K, and B is K x N. * In xSYMM, xTRMM, and xTRSM, K indicates whether the matrix * A is applied on the left or right. If K <= 0, the matrix * is applied on the left, if K > 0, on the right. * * ===================================================================== * * .. Local Scalars .. CHARACTER C1 CHARACTER*2 C2 CHARACTER*3 C3 REAL ADDS, EK, EM, EN, MULTS * .. * .. External Functions .. LOGICAL LSAME, LSAMEN EXTERNAL LSAME, LSAMEN * .. * .. Executable Statements .. * * Quick return if possible * IF( M.LE.0 .OR. $ .NOT.( LSAME( SUBNAM, 'S' ) .OR. LSAME( SUBNAM, 'D' ) .OR. $ LSAME( SUBNAM, 'C' ) .OR. LSAME( SUBNAM, 'Z' ) ) ) THEN SOPBL3 = 0 RETURN END IF * C1 = SUBNAM( 1: 1 ) C2 = SUBNAM( 2: 3 ) C3 = SUBNAM( 4: 6 ) MULTS = 0 ADDS = 0 EM = M EN = N EK = K * * ---------------------- * Matrix-matrix products * assume beta = 1 * ---------------------- * IF( LSAMEN( 3, C3, 'MM ' ) ) THEN * IF( LSAMEN( 2, C2, 'GE' ) ) THEN * MULTS = EM*EK*EN ADDS = EM*EK*EN * ELSE IF( LSAMEN( 2, C2, 'SY' ) .OR. $ LSAMEN( 3, SUBNAM, 'CHE' ) .OR. $ LSAMEN( 3, SUBNAM, 'ZHE' ) ) THEN * * IF K <= 0, assume A multiplies B on the left. * IF( K.LE.0 ) THEN MULTS = EM*EM*EN ADDS = EM*EM*EN ELSE MULTS = EM*EN*EN ADDS = EM*EN*EN END IF * ELSE IF( LSAMEN( 2, C2, 'TR' ) ) THEN * IF( K.LE.0 ) THEN MULTS = EN*EM*( EM+1. ) / 2. ADDS = EN*EM*( EM-1. ) / 2. ELSE MULTS = EM*EN*( EN+1. ) / 2. ADDS = EM*EN*( EN-1. ) / 2. END IF * END IF * * ------------------------------------------------ * Rank-K update of a symmetric or Hermitian matrix * ------------------------------------------------ * ELSE IF( LSAMEN( 3, C3, 'RK ' ) ) THEN * IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 3, SUBNAM, 'CHE' ) .OR. $ LSAMEN( 3, SUBNAM, 'ZHE' ) ) THEN * MULTS = EK*EM*( EM+1. ) / 2. ADDS = EK*EM*( EM+1. ) / 2. END IF * * ------------------------------------------------ * Rank-2K update of a symmetric or Hermitian matrix * ------------------------------------------------ * ELSE IF( LSAMEN( 3, C3, 'R2K' ) ) THEN * IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 3, SUBNAM, 'CHE' ) .OR. $ LSAMEN( 3, SUBNAM, 'ZHE' ) ) THEN * MULTS = EK*EM*EM ADDS = EK*EM*EM + EM END IF * * ----------------------------------------- * Solving system with many right hand sides * ----------------------------------------- * ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'TRSM ' ) ) THEN * IF( K.LE.0 ) THEN MULTS = EN*EM*( EM+1. ) / 2. ADDS = EN*EM*( EM-1. ) / 2. ELSE MULTS = EM*EN*( EN+1. ) / 2. ADDS = EM*EN*( EN-1. ) / 2. END IF * END IF * * ------------------------------------------------ * Compute the total number of operations. * For real and double precision routines, count * 1 for each multiply and 1 for each add. * For complex and complex*16 routines, count * 6 for each multiply and 2 for each add. * ------------------------------------------------ * IF( LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' ) ) THEN * SOPBL3 = MULTS + ADDS * ELSE * SOPBL3 = 6*MULTS + 2*ADDS * END IF * RETURN * * End of SOPBL3 * END SHAR_EOF fi # end of overwriting check if test -f 'sopla.f' then echo shar: will not over-write existing file "'sopla.f'" else cat << SHAR_EOF > 'sopla.f' REAL FUNCTION SOPLA( SUBNAM, M, N, KL, KU, NB ) * * -- LAPACK timing routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER*6 SUBNAM INTEGER KL, KU, M, N, NB * .. * * Purpose * ======= * * SOPLA computes an approximation of the number of floating point * operations used by the subroutine SUBNAM with the given values * of the parameters M, N, KL, KU, and NB. * * This version counts operations for the LAPACK subroutines. * * Arguments * ========= * * SUBNAM (input) CHARACTER*6 * The name of the subroutine. * * M (input) INTEGER * The number of rows of the coefficient matrix. M >= 0. * * N (input) INTEGER * The number of columns of the coefficient matrix. * For solve routine when the matrix is square, * N is the number of right hand sides. N >= 0. * * KL (input) INTEGER * The lower band width of the coefficient matrix. * If needed, 0 <= KL <= M-1. * For xGEQRS, KL is the number of right hand sides. * * KU (input) INTEGER * The upper band width of the coefficient matrix. * If needed, 0 <= KU <= N-1. * * NB (input) INTEGER * The block size. If needed, NB >= 1. * * Notes * ===== * * In the comments below, the association is given between arguments * in the requested subroutine and local arguments. For example, * * xGETRS: N, NRHS => M, N * * means that arguments N and NRHS in SGETRS are passed to arguments * M and N in this procedure. * * ===================================================================== * * .. Local Scalars .. LOGICAL CORZ, SORD CHARACTER C1 CHARACTER*2 C2 CHARACTER*3 C3 INTEGER I REAL ADDFAC, ADDS, EK, EM, EMN, EN, MULFAC, MULTS, $ WL, WU * .. * .. External Functions .. LOGICAL LSAME, LSAMEN EXTERNAL LSAME, LSAMEN * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * -------------------------------------------------------- * Initialize SOPLA to 0 and do a quick return if possible. * -------------------------------------------------------- * SOPLA = 0 MULTS = 0 ADDS = 0 C1 = SUBNAM( 1: 1 ) C2 = SUBNAM( 2: 3 ) C3 = SUBNAM( 4: 6 ) SORD = LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' ) CORZ = LSAME( C1, 'C' ) .OR. LSAME( C1, 'Z' ) IF( M.LE.0 .OR. .NOT.( SORD .OR. CORZ ) ) $ RETURN * * --------------------------------------------------------- * If the coefficient matrix is real, count each add as 1 * operation and each multiply as 1 operation. * If the coefficient matrix is complex, count each add as 2 * operations and each multiply as 6 operations. * --------------------------------------------------------- * IF( LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' ) ) THEN ADDFAC = 1 MULFAC = 1 ELSE ADDFAC = 2 MULFAC = 6 END IF EM = M EN = N EK = KL * * --------------------------------- * GE: GEneral rectangular matrices * --------------------------------- * IF( LSAMEN( 2, C2, 'GE' ) ) THEN * * xGETRF: M, N => M, N * IF( LSAMEN( 3, C3, 'TRF' ) ) THEN EMN = MIN( M, N ) ADDS = EMN*( EM*EN-( EM+EN )*( EMN+1. ) / 2.+( EMN+1. )* $ ( 2.*EMN+1. ) / 6. ) MULTS = ADDS + EMN*( EM-( EMN+1. ) / 2. ) * * xGETRS: N, NRHS => M, N * ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN MULTS = EN*EM*EM ADDS = EN*( EM*( EM-1. ) ) * * xGETRI: N => M * ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN MULTS = EM*( 5. / 6.+EM*( 1. / 2.+EM*( 2. / 3. ) ) ) ADDS = EM*( 5. / 6.+EM*( -3. / 2.+EM*( 2. / 3. ) ) ) * * xGEQRF or xGEQLF: M, N => M, N * ELSE IF( LSAMEN( 3, C3, 'QRF' ) .OR. $ LSAMEN( 3, C3, 'QR2' ) .OR. $ LSAMEN( 3, C3, 'QLF' ) .OR. LSAMEN( 3, C3, 'QL2' ) ) $ THEN IF( M.GE.N ) THEN MULTS = EN*( ( ( 23. / 6. )+EM+EN / 2. )+EN* $ ( EM-EN / 3. ) ) ADDS = EN*( ( 5. / 6. )+EN*( 1. / 2.+( EM-EN / 3. ) ) ) ELSE MULTS = EM*( ( ( 23. / 6. )+2.*EN-EM / 2. )+EM* $ ( EN-EM / 3. ) ) ADDS = EM*( ( 5. / 6. )+EN-EM / 2.+EM*( EN-EM / 3. ) ) END IF * * xGERQF or xGELQF: M, N => M, N * ELSE IF( LSAMEN( 3, C3, 'RQF' ) .OR. $ LSAMEN( 3, C3, 'RQ2' ) .OR. $ LSAMEN( 3, C3, 'LQF' ) .OR. LSAMEN( 3, C3, 'LQ2' ) ) $ THEN IF( M.GE.N ) THEN MULTS = EN*( ( ( 29. / 6. )+EM+EN / 2. )+EN* $ ( EM-EN / 3. ) ) ADDS = EN*( ( 5. / 6. )+EM+EN* $ ( -1. / 2.+( EM-EN / 3. ) ) ) ELSE MULTS = EM*( ( ( 29. / 6. )+2.*EN-EM / 2. )+EM* $ ( EN-EM / 3. ) ) ADDS = EM*( ( 5. / 6. )+EM / 2.+EM*( EN-EM / 3. ) ) END IF * * xGEQPF: M, N => M, N * ELSE IF( LSAMEN( 3, C3, 'QPF' ) ) THEN EMN = MIN( M, N ) MULTS = 2*EN*EN + EMN*( 3*EM+5*EN+2*EM*EN-( EMN+1 )* $ ( 4+EN+EM-( 2*EMN+1 ) / 3 ) ) ADDS = EN*EN + EMN*( 2*EM+EN+2*EM*EN-( EMN+1 )* $ ( 2+EN+EM-( 2*EMN+1 ) / 3 ) ) * * xGEQRS or xGERQS: M, N, NRHS => M, N, KL * ELSE IF( LSAMEN( 3, C3, 'QRS' ) .OR. LSAMEN( 3, C3, 'RQS' ) ) $ THEN MULTS = EK*( EN*( 2.-EK )+EM*( 2.*EN+( EM+1. ) / 2. ) ) ADDS = EK*( EN*( 1.-EK )+EM*( 2.*EN+( EM-1. ) / 2. ) ) * * xGELQS or xGEQLS: M, N, NRHS => M, N, KL * ELSE IF( LSAMEN( 3, C3, 'LQS' ) .OR. LSAMEN( 3, C3, 'QLS' ) ) $ THEN MULTS = EK*( EM*( 2.-EK )+EN*( 2.*EM+( EN+1. ) / 2. ) ) ADDS = EK*( EM*( 1.-EK )+EN*( 2.*EM+( EN-1. ) / 2. ) ) * * xGEBRD: M, N => M, N * ELSE IF( LSAMEN( 3, C3, 'BRD' ) ) THEN IF( M.GE.N ) THEN MULTS = EN*( 20. / 3.+EN*( 2.+( 2.*EM-( 2. / 3. )* $ EN ) ) ) ADDS = EN*( 5. / 3.+( EN-EM )+EN* $ ( 2.*EM-( 2. / 3. )*EN ) ) ELSE MULTS = EM*( 20. / 3.+EM*( 2.+( 2.*EN-( 2. / 3. )* $ EM ) ) ) ADDS = EM*( 5. / 3.+( EM-EN )+EM* $ ( 2.*EN-( 2. / 3. )*EM ) ) END IF * * xGEHRD: N => M * ELSE IF( LSAMEN( 3, C3, 'HRD' ) ) THEN IF( M.EQ.1 ) THEN MULTS = 0. ADDS = 0. ELSE MULTS = -13. + EM*( -7. / 6.+EM*( 0.5+EM*( 5. / 3. ) ) ) ADDS = -8. + EM*( -2. / 3.+EM*( -1.+EM*( 5. / 3. ) ) ) END IF * END IF * * ---------------------------- * GB: General Banded matrices * ---------------------------- * Note: The operation count is overestimated because * it is assumed that the factor U fills in to the maximum * extent, i.e., that its bandwidth goes from KU to KL + KU. * ELSE IF( LSAMEN( 2, C2, 'GB' ) ) THEN * * xGBTRF: M, N, KL, KU => M, N, KL, KU * IF( LSAMEN( 3, C3, 'TRF' ) ) THEN DO 10 I = MIN( M, N ), 1, -1 WL = MAX( 0, MIN( KL, M-I ) ) WU = MAX( 0, MIN( KL+KU, N-I ) ) MULTS = MULTS + WL*( 1.+WU ) ADDS = ADDS + WL*WU 10 CONTINUE * * xGBTRS: N, NRHS, KL, KU => M, N, KL, KU * ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN WL = MAX( 0, MIN( KL, M-1 ) ) WU = MAX( 0, MIN( KL+KU, M-1 ) ) MULTS = EN*( EM*( WL+1.+WU )-0.5* $ ( WL*( WL+1. )+WU*( WU+1. ) ) ) ADDS = EN*( EM*( WL+WU )-0.5*( WL*( WL+1. )+WU*( WU+1. ) ) ) * END IF * * -------------------------------------- * PO: POsitive definite matrices * PP: Positive definite Packed matrices * -------------------------------------- * ELSE IF( LSAMEN( 2, C2, 'PO' ) .OR. LSAMEN( 2, C2, 'PP' ) ) THEN * * xPOTRF: N => M * IF( LSAMEN( 3, C3, 'TRF' ) ) THEN MULTS = EM*( 1. / 3.+EM*( 1. / 2.+EM*( 1. / 6. ) ) ) ADDS = ( 1. / 6. )*EM*( -1.+EM*EM ) * * xPOTRS: N, NRHS => M, N * ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN MULTS = EN*( EM*( EM+1. ) ) ADDS = EN*( EM*( EM-1. ) ) * * xPOTRI: N => M * ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN MULTS = EM*( 2. / 3.+EM*( 1.+EM*( 1. / 3. ) ) ) ADDS = EM*( 1. / 6.+EM*( -1. / 2.+EM*( 1. / 3. ) ) ) * END IF * * ------------------------------------ * PB: Positive definite Band matrices * ------------------------------------ * ELSE IF( LSAMEN( 2, C2, 'PB' ) ) THEN * * xPBTRF: N, K => M, KL * IF( LSAMEN( 3, C3, 'TRF' ) ) THEN MULTS = EK*( -2. / 3.+EK*( -1.+EK*( -1. / 3. ) ) ) + $ EM*( 1.+EK*( 3. / 2.+EK*( 1. / 2. ) ) ) ADDS = EK*( -1. / 6.+EK*( -1. / 2.+EK*( -1. / 3. ) ) ) + $ EM*( EK / 2.*( 1.+EK ) ) * * xPBTRS: N, NRHS, K => M, N, KL * ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN MULTS = EN*( ( 2*EM-EK )*( EK+1. ) ) ADDS = EN*( EK*( 2*EM-( EK+1. ) ) ) * END IF * * ---------------------------------- * PT: Positive definite Tridiagonal * ---------------------------------- * ELSE IF( LSAMEN( 2, C2, 'PT' ) ) THEN * * xPTTRF: N => M * IF( LSAMEN( 3, C3, 'TRF' ) ) THEN MULTS = 2*( EM-1 ) ADDS = EM - 1 * * xPTTRS: N, NRHS => M, N * ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN MULTS = EN*( 3*EM-2 ) ADDS = EN*( 2*( EM-1 ) ) * * xPTSV: N, NRHS => M, N * ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN MULTS = 2*( EM-1 ) + EN*( 3*EM-2 ) ADDS = EM - 1 + EN*( 2*( EM-1 ) ) END IF * * -------------------------------------------------------- * SY: SYmmetric indefinite matrices * SP: Symmetric indefinite Packed matrices * HE: HErmitian indefinite matrices (complex only) * HP: Hermitian indefinite Packed matrices (complex only) * -------------------------------------------------------- * ELSE IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 2, C2, 'SP' ) .OR. $ LSAMEN( 3, SUBNAM, 'CHE' ) .OR. $ LSAMEN( 3, SUBNAM, 'ZHE' ) .OR. $ LSAMEN( 3, SUBNAM, 'CHP' ) .OR. $ LSAMEN( 3, SUBNAM, 'ZHP' ) ) THEN * * xSYTRF: N => M * IF( LSAMEN( 3, C3, 'TRF' ) ) THEN MULTS = EM*( 10. / 3.+EM*( 1. / 2.+EM*( 1. / 6. ) ) ) ADDS = EM / 6.*( -1.+EM*EM ) * * xSYTRS: N, NRHS => M, N * ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN MULTS = EN*EM*EM ADDS = EN*( EM*( EM-1. ) ) * * xSYTRI: N => M * ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN MULTS = EM*( 2. / 3.+EM*EM*( 1. / 3. ) ) ADDS = EM*( -1. / 3.+EM*EM*( 1. / 3. ) ) * * xSYTRD, xSYTD2: N => M * ELSE IF( LSAMEN( 3, C3, 'TRD' ) .OR. LSAMEN( 3, C3, 'TD2' ) ) $ THEN IF( M.EQ.1 ) THEN MULTS = 0. ADDS = 0. ELSE MULTS = -15. + EM*( -1. / 6.+EM* $ ( 5. / 2.+EM*( 2. / 3. ) ) ) ADDS = -4. + EM*( -8. / 3.+EM*( 1.+EM*( 2. / 3. ) ) ) END IF END IF * * ------------------- * Triangular matrices * ------------------- * ELSE IF( LSAMEN( 2, C2, 'TR' ) .OR. LSAMEN( 2, C2, 'TP' ) ) THEN * * xTRTRS: N, NRHS => M, N * IF( LSAMEN( 3, C3, 'TRS' ) ) THEN MULTS = EN*EM*( EM+1. ) / 2. ADDS = EN*EM*( EM-1. ) / 2. * * xTRTRI: N => M * ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN MULTS = EM*( 1. / 3.+EM*( 1. / 2.+EM*( 1. / 6. ) ) ) ADDS = EM*( 1. / 3.+EM*( -1. / 2.+EM*( 1. / 6. ) ) ) * END IF * ELSE IF( LSAMEN( 2, C2, 'TB' ) ) THEN * * xTBTRS: N, NRHS, K => M, N, KL * IF( LSAMEN( 3, C3, 'TRS' ) ) THEN MULTS = EN*( EM*( EM+1. ) / 2.-( EM-EK-1. )*( EM-EK ) / 2. ) ADDS = EN*( EM*( EM-1. ) / 2.-( EM-EK-1. )*( EM-EK ) / 2. ) END IF * * -------------------- * Trapezoidal matrices * -------------------- * ELSE IF( LSAMEN( 2, C2, 'TZ' ) ) THEN * * xTZRQF: M, N => M, N * IF( LSAMEN( 3, C3, 'RQF' ) ) THEN EMN = MIN( M, N ) MULTS = 3*EM*( EN-EM+1 ) + ( 2*EN-2*EM+3 )* $ ( EM*EM-EMN*( EMN+1 ) / 2 ) ADDS = ( EN-EM+1 )*( EM+2*EM*EM-EMN*( EMN+1 ) ) END IF * * ------------------- * Orthogonal matrices * ------------------- * ELSE IF( ( SORD .AND. LSAMEN( 2, C2, 'OR' ) ) .OR. $ ( CORZ .AND. LSAMEN( 2, C2, 'UN' ) ) ) THEN * * -MQR, -MLQ, -MQL, or -MRQ: M, N, K, SIDE => M, N, KL, KU * where KU<= 0 indicates SIDE = 'L' * and KU> 0 indicates SIDE = 'R' * IF( LSAMEN( 3, C3, 'MQR' ) .OR. LSAMEN( 3, C3, 'MLQ' ) .OR. $ LSAMEN( 3, C3, 'MQL' ) .OR. LSAMEN( 3, C3, 'MRQ' ) ) THEN IF( KU.LE.0 ) THEN MULTS = EK*EN*( 2.*EM+2.-EK ) ADDS = EK*EN*( 2.*EM+1.-EK ) ELSE MULTS = EK*( EM*( 2.*EN-EK )+( EM+EN+( 1.-EK ) / 2. ) ) ADDS = EK*EM*( 2.*EN+1.-EK ) END IF * * -GQR or -GQL: M, N, K => M, N, KL * ELSE IF( LSAMEN( 3, C3, 'GQR' ) .OR. LSAMEN( 3, C3, 'GQL' ) ) $ THEN MULTS = EK*( -5. / 3.+( 2.*EN-EK )+ $ ( 2.*EM*EN+EK*( ( 2. / 3. )*EK-EM-EN ) ) ) ADDS = EK*( 1. / 3.+( EN-EM )+ $ ( 2.*EM*EN+EK*( ( 2. / 3. )*EK-EM-EN ) ) ) * * -GLQ or -GRQ: M, N, K => M, N, KL * ELSE IF( LSAMEN( 3, C3, 'GLQ' ) .OR. LSAMEN( 3, C3, 'GRQ' ) ) $ THEN MULTS = EK*( -2. / 3.+( EM+EN-EK )+ $ ( 2.*EM*EN+EK*( ( 2. / 3. )*EK-EM-EN ) ) ) ADDS = EK*( 1. / 3.+( EM-EN )+ $ ( 2.*EM*EN+EK*( ( 2. / 3. )*EK-EM-EN ) ) ) * END IF * END IF * SOPLA = MULFAC*MULTS + ADDFAC*ADDS * RETURN * * End of SOPLA * END SHAR_EOF fi # end of overwriting check if test -f 'sprtb4.f' then echo shar: will not over-write existing file "'sprtb4.f'" else cat << SHAR_EOF > 'sprtb4.f' SUBROUTINE SPRTB4( LAB1, LABM, LABN, NK, KVAL, LVAL, NM, MVAL, $ NVAL, NLDA, RESLTS, LDR1, LDR2, NOUT ) * * -- LAPACK timing routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER*( * ) LAB1, LABM, LABN INTEGER LDR1, LDR2, NK, NLDA, NM, NOUT * .. * .. Array Arguments .. INTEGER KVAL( NK ), LVAL( NK ), MVAL( NM ), NVAL( NM ) REAL RESLTS( LDR1, LDR2, * ) * .. * * Purpose * ======= * * SPRTB4 prints a table of timing data for the timing programs. * The table has NK block rows and NM columns, with NLDA * individual rows in each block row. Each block row depends on two * parameters K and L, specified as an ordered pair in the arrays KVAL * and LVAL, and each column depends on two parameters M and N, * specified as an ordered pair in the arrays MVAL and NVAL. * * Arguments * ========= * * LAB1 (input) CHARACTER*(*) * The label for the rows. * * LABM (input) CHARACTER*(*) * The first label for the columns. * * LABN (input) CHARACTER*(*) * The second label for the columns. * * NK (input) INTEGER * The number of values of KVAL and LVAL, and also the number of * block rows of the table. Each block row depends on the pair * of parameters (K,L). * * KVAL (input) INTEGER array, dimension (NK) * The values of the parameter K. * * LVAL (input) INTEGER array, dimension (NK) * The values of the parameter L. * * NM (input) INTEGER * The number of values of MVAL and NVAL, and also the number of * columns of the table. Each column depends on the pair of * parameters (M,N). * * MVAL (input) INTEGER array, dimension (NM) * The values of the parameter M. * * NVAL (input) INTEGER array, dimension (NM) * The values of the parameter N. * * NLDA (input) INTEGER * The number of values of LDA, hence the number of rows for * each pair of values (K,L). * * RESLTS (input) REAL array, dimension (LDR1, LDR2, NLDA) * The timing results for each value of (M,N), (K,L), and LDA. * * LDR1 (input) INTEGER * The first dimension of RESLTS. LDR1 >= max(1,NK). * * LDR2 (input) INTEGER * The second dimension of RESLTS. LDR2 >= max(1,NM). * * NOUT (input) INTEGER * The unit number on which the table is to be printed. * NOUT >= 0. * * ===================================================================== * * .. Local Scalars .. INTEGER I, J, K * .. * .. Executable Statements .. * IF( NOUT.LE.0 ) $ RETURN WRITE( NOUT, FMT = 9999 )LABM, ( MVAL( I ), I = 1, NM ) WRITE( NOUT, FMT = 9999 )LABN, ( NVAL( I ), I = 1, NM ) WRITE( NOUT, FMT = 9998 )LAB1 * DO 20 I = 1, NK IF( LAB1.EQ.' ' ) THEN WRITE( NOUT, FMT = 9996 )( RESLTS( 1, J, 1 ), J = 1, NM ) ELSE WRITE( NOUT, FMT = 9997 )KVAL( I ), LVAL( I ), $ ( RESLTS( I, J, 1 ), J = 1, NM ) END IF DO 10 K = 2, NLDA WRITE( NOUT, FMT = 9996 )( RESLTS( I, J, K ), J = 1, NM ) 10 CONTINUE IF( NLDA.GT.1 ) $ WRITE( NOUT, FMT = * ) 20 CONTINUE IF( NLDA.EQ.1 ) $ WRITE( NOUT, FMT = * ) RETURN * 9999 FORMAT( 10X, A4, I7, 11I8 ) 9998 FORMAT( 1X, A11 ) 9997 FORMAT( 1X, '(', I4, ',', I4, ') ', 12F8.1 ) 9996 FORMAT( 13X, 12F8.1 ) * * End of SPRTB4 * END SHAR_EOF fi # end of overwriting check if test -f 'sprtb5.f' then echo shar: will not over-write existing file "'sprtb5.f'" else cat << SHAR_EOF > 'sprtb5.f' SUBROUTINE SPRTB5( LAB1, LABM, LABN, NK, KVAL, NM, MVAL, NVAL, $ NLDA, RESLTS, LDR1, LDR2, NOUT ) * * -- LAPACK timing routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER*( * ) LAB1, LABM, LABN INTEGER LDR1, LDR2, NK, NLDA, NM, NOUT * .. * .. Array Arguments .. INTEGER KVAL( NK ), MVAL( NM ), NVAL( NM ) REAL RESLTS( LDR1, LDR2, * ) * .. * * Purpose * ======= * * SPRTB5 prints a table of timing data for the timing programs. * The table has NK block rows and NM columns, with NLDA * individual rows in each block row. Each column depends on two * parameters M and N, specified as an ordered pair in the arrays MVAL * and NVAL. * * Arguments * ========= * * LAB1 (input) CHARACTER*(*) * The label for the rows. * * LABM (input) CHARACTER*(*) * The first label for the columns. * * LABN (input) CHARACTER*(*) * The second label for the columns. * * NK (input) INTEGER * The number of values of KVAL, and also the number of block * rows of the table. * * KVAL (input) INTEGER array, dimension (NK) * The values of LAB1 used for the data in each block row. * * NM (input) INTEGER * The number of values of MVAL and NVAL, and also the number of * columns of the table. Each column depends on the pair of * parameters (M,N). * * MVAL (input) INTEGER array, dimension (NM) * The values of the parameter M. * * NVAL (input) INTEGER array, dimension (NM) * The values of the parameter N. * * NLDA (input) INTEGER * The number of values of LDA, hence the number of rows for * each value of KVAL. * * RESLTS (input) REAL array, dimension (LDR1, LDR2, NLDA) * The timing results for each value of N, K, and LDA. * * LDR1 (input) INTEGER * The first dimension of RESLTS. LDR1 >= max(1,NK). * * LDR2 (input) INTEGER * The second dimension of RESLTS. LDR2 >= max(1,NM). * * NOUT (input) INTEGER * The unit number on which the table is to be printed. * NOUT >= 0. * * ===================================================================== * * .. Local Scalars .. INTEGER I, J, K * .. * .. Executable Statements .. * IF( NOUT.LE.0 ) $ RETURN WRITE( NOUT, FMT = 9999 )LABM, ( MVAL( I ), I = 1, NM ) WRITE( NOUT, FMT = 9999 )LABN, ( NVAL( I ), I = 1, NM ) WRITE( NOUT, FMT = 9998 )LAB1 * DO 20 I = 1, NK IF( LAB1.EQ.' ' ) THEN WRITE( NOUT, FMT = 9996 )( RESLTS( 1, J, 1 ), J = 1, NM ) ELSE WRITE( NOUT, FMT = 9997 )KVAL( I ), $ ( RESLTS( I, J, 1 ), J = 1, NM ) END IF DO 10 K = 2, NLDA WRITE( NOUT, FMT = 9996 )( RESLTS( I, J, K ), J = 1, NM ) 10 CONTINUE IF( NLDA.GT.1 ) $ WRITE( NOUT, FMT = * ) 20 CONTINUE IF( NLDA.EQ.1 ) $ WRITE( NOUT, FMT = * ) RETURN * 9999 FORMAT( 6X, A4, I6, 11I8 ) 9998 FORMAT( 3X, A4 ) 9997 FORMAT( 1X, I6, 1X, 12F8.1 ) 9996 FORMAT( 8X, 12F8.1 ) * * End of SPRTB5 * END SHAR_EOF fi # end of overwriting check if test -f 'sprtbl.f' then echo shar: will not over-write existing file "'sprtbl.f'" else cat << SHAR_EOF > 'sprtbl.f' SUBROUTINE SPRTBL( LAB1, LAB2, NK, KVAL, NN, NVAL, NLDA, RESLTS, $ LDR1, LDR2, NOUT ) * * -- LAPACK timing routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER*( * ) LAB1, LAB2 INTEGER LDR1, LDR2, NK, NLDA, NN, NOUT * .. * .. Array Arguments .. INTEGER KVAL( NK ), NVAL( NN ) REAL RESLTS( LDR1, LDR2, * ) * .. * * Purpose * ======= * * SPRTBL prints a table of timing data for the timing programs. * The table has NK block rows and NN columns, with NLDA * individual rows in each block row. * * Arguments * ========= * * LAB1 (input) CHARACTER*(*) * The label for the rows. * * LAB2 (input) CHARACTER*(*) * The label for the columns. * * NK (input) INTEGER * The number of values of KVAL, and also the number of block * rows of the table. * * KVAL (input) INTEGER array, dimension (NK) * The values of LAB1 used for the data in each block row. * * NN (input) INTEGER * The number of values of NVAL, and also the number of columns * of the table. * * NVAL (input) INTEGER array, dimension (NN) * The values of LAB2 used for the data in each column. * * NLDA (input) INTEGER * The number of values of LDA, hence the number of rows for * each value of KVAL. * * RESLTS (input) REAL array, dimension (LDR1, LDR2, NLDA) * The timing results for each value of N, K, and LDA. * * LDR1 (input) INTEGER * The first dimension of RESLTS. LDR1 >= max( 1, NK ). * * LDR2 (input) INTEGER * The second dimension of RESLTS. LDR2 >= max( 1, NN ). * * NOUT (input) INTEGER * The unit number on which the table is to be printed. * NOUT >= 0. * * ===================================================================== * * .. Local Scalars .. INTEGER I, J, K * .. * .. Executable Statements .. * IF( NOUT.LE.0 ) $ RETURN WRITE( NOUT, FMT = 9999 )LAB2, ( NVAL( I ), I = 1, NN ) WRITE( NOUT, FMT = 9998 )LAB1 * DO 20 I = 1, NK IF( LAB1.EQ.' ' ) THEN WRITE( NOUT, FMT = 9996 )( RESLTS( 1, J, 1 ), J = 1, NN ) ELSE WRITE( NOUT, FMT = 9997 )KVAL( I ), $ ( RESLTS( I, J, 1 ), J = 1, NN ) END IF DO 10 K = 2, NLDA WRITE( NOUT, FMT = 9996 )( RESLTS( I, J, K ), J = 1, NN ) 10 CONTINUE IF( NLDA.GT.1 ) $ WRITE( NOUT, FMT = * ) 20 CONTINUE IF( NLDA.EQ.1 ) $ WRITE( NOUT, FMT = * ) RETURN * 9999 FORMAT( 6X, A4, I6, 11I8 ) 9998 FORMAT( 3X, A4 ) 9997 FORMAT( 1X, I6, 1X, 12F8.1 ) 9996 FORMAT( 8X, 12F8.1 ) * * End of SPRTBL * END SHAR_EOF fi # end of overwriting check if test -f 'stimaa.f' then echo shar: will not over-write existing file "'stimaa.f'" else cat << SHAR_EOF > 'stimaa.f' PROGRAM STIMAA * * -- LAPACK timing routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * Rewritten to include the timing of rrqr code. * * Purpose * ======= * * An annotated example of a data file can be obtained by deleting the * first 3 characters from the following lines: * LAPACK timing, REAL square matrices * 5 Number of values of M * 100 200 300 400 500 Values of M (row dimension) * 5 Number of values of N * 100 200 300 400 500 Values of N (column dimension) * 2 Number of values of K * 100 400 Values of K * 5 Number of values of NB * 1 16 32 48 64 Values of NB (blocksize) * 0 48 128 128 128 Values of NX (crossover point) * 2 Number of values of LDA * 512 513 Values of LDA (leading dimension) * 0.0 Minimum time in seconds * SQR T T F * SQP T * SRR T * * The routines are timed for all combinations of applicable values of * M, N, K, NB, NX, and LDA, and for all combinations of options such as * UPLO and TRANS. For Level 2 BLAS timings, values of NB are used for * INCX. Certain subroutines, such as the QR factorization, treat the * values of M and N as ordered pairs and operate on M x N matrices. * * Internal Parameters * =================== * * NMAX INTEGER * The maximum value of M or N for square matrices. * * LDAMAX INTEGER * The maximum value of LDA. * * NMAXB INTEGER * The maximum value of N for band matrices. * * MAXVAL INTEGER * The maximum number of values that can be read in for M, N, * K, NB, or NX. * * MXNLDA INTEGER * The maximum number of values that can be read in for LDA. * * NIN INTEGER * The unit number for input. Currently set to 5 (std input). * * NOUT INTEGER * The unit number for output. Currently set to 6 (std output). * * ===================================================================== * * .. Parameters .. INTEGER NMAX, LDAMAX, NMAXB PARAMETER ( NMAX = 1001, LDAMAX = NMAX+4, NMAXB = 5000 ) INTEGER LA PARAMETER ( LA = NMAX*LDAMAX ) INTEGER MAXVAL, MXNLDA PARAMETER ( MAXVAL = 12, MXNLDA = 4 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) * .. * .. Local Scalars .. LOGICAL BLAS, LDAMOK, LDANOK, LDAOK, MOK, NOK, NXNBOK CHARACTER C1 CHARACTER*2 C2 CHARACTER*3 C3 CHARACTER*80 LINE INTEGER I, L, LDR1, LDR2, LDR3, MAXK, MAXLDA, $ MAXM, MAXN, MAXNB, MKMAX, NEED, NK, NLDA, NM, $ NN, NNB REAL S1, S2, TIMMIN * .. * .. Local Arrays .. INTEGER IWORK( 2*NMAXB ), KVAL( MAXVAL ), $ LDAVAL( MXNLDA ), MVAL( MAXVAL ), $ NBVAL( MAXVAL ), NVAL( MAXVAL ), $ NXVAL( MAXVAL ) REAL A( LA, 4 ), D( 2*NMAX, 2 ), $ RESLTS( MAXVAL, MAXVAL, 2*MXNLDA, 4*MAXVAL ) * .. * .. External Functions .. LOGICAL LSAME, LSAMEN REAL SECOND EXTERNAL LSAME, LSAMEN, SECOND * .. * .. External Subroutines .. EXTERNAL STIMMM, STIMMV, STIMQP, STIMQR, $ STIMRR * .. * .. Scalars in Common .. INTEGER NB, NEISPK, NPROC, NSHIFT * .. * .. Common blocks .. COMMON / CENVIR / NB, NPROC, NSHIFT, NEISPK * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * S1 = SECOND( ) LDR1 = MAXVAL LDR2 = MAXVAL LDR3 = 2*MXNLDA * * Read the first line. The first four characters must be 'BLAS' * for the BLAS data file format to be used. Otherwise, the LAPACK * data file format is assumed. * READ( NIN, FMT = '( A80 )' )LINE BLAS = LSAMEN( 4, LINE, 'BLAS' ) * * Find the last non-blank and print the first line of input as the * first line of output. * DO 10 L = 80, 1, -1 IF( LINE( L: L ).NE.' ' ) $ GO TO 20 10 CONTINUE L = 1 20 CONTINUE WRITE( NOUT, FMT = '( 1X, A, / )' )LINE( 1: L ) WRITE( NOUT, FMT = 9992 ) * * Read in NM and the values for M. * READ( NIN, FMT = * )NM IF( NM.GT.MAXVAL ) THEN WRITE( NOUT, FMT = 9999 )'M', 'NM', MAXVAL NM = MAXVAL END IF READ( NIN, FMT = * )( MVAL( I ), I = 1, NM ) WRITE( NOUT, FMT = 9991 )'M: ', ( MVAL( I ), I = 1, NM ) * * Check that M <= NMAXB for all values of M. * MOK = .TRUE. MAXM = 0 DO 30 I = 1, NM MAXM = MAX( MVAL( I ), MAXM ) IF( MVAL( I ).GT.NMAXB ) THEN WRITE( NOUT, FMT = 9997 )'M', MVAL( I ), NMAXB MOK = .FALSE. END IF 30 CONTINUE IF( .NOT.MOK ) $ WRITE( NOUT, FMT = * ) * * Read in NN and the values for N. * READ( NIN, FMT = * )NN IF( NN.GT.MAXVAL ) THEN WRITE( NOUT, FMT = 9999 )'N', 'NN', MAXVAL NN = MAXVAL END IF READ( NIN, FMT = * )( NVAL( I ), I = 1, NN ) WRITE( NOUT, FMT = 9991 )'N: ', ( NVAL( I ), I = 1, NN ) * * Check that N <= NMAXB for all values of N. * NOK = .TRUE. MAXN = 0 DO 40 I = 1, NN MAXN = MAX( NVAL( I ), MAXN ) IF( NVAL( I ).GT.NMAXB ) THEN WRITE( NOUT, FMT = 9997 )'N', NVAL( I ), NMAXB NOK = .FALSE. END IF 40 CONTINUE IF( .NOT.NOK ) $ WRITE( NOUT, FMT = * ) * * Read in NK and the values for K. * READ( NIN, FMT = * )NK IF( NK.GT.MAXVAL ) THEN WRITE( NOUT, FMT = 9999 )'K', 'NK', MAXVAL NK = MAXVAL END IF READ( NIN, FMT = * )( KVAL( I ), I = 1, NK ) WRITE( NOUT, FMT = 9991 )'K: ', ( KVAL( I ), I = 1, NK ) * * Find the maximum value of K (= NRHS). * MAXK = 0 DO 50 I = 1, NK MAXK = MAX( KVAL( I ), MAXK ) 50 CONTINUE MKMAX = MAXM*MAX( 2, MAXK ) * * Read in NNB and the values for NB. For the BLAS input files, * NBVAL is used to store values for INCX and INCY. * READ( NIN, FMT = * )NNB IF( NNB.GT.MAXVAL ) THEN WRITE( NOUT, FMT = 9999 )'NB', 'NNB', MAXVAL NNB = MAXVAL END IF READ( NIN, FMT = * )( NBVAL( I ), I = 1, NNB ) * * Find the maximum value of NB. * MAXNB = 0 DO 60 I = 1, NNB MAXNB = MAX( NBVAL( I ), MAXNB ) 60 CONTINUE * IF( BLAS ) THEN WRITE( NOUT, FMT = 9991 )'INCX: ', ( NBVAL( I ), I = 1, NNB ) DO 70 I = 1, NNB NXVAL( I ) = 0 70 CONTINUE ELSE * * LAPACK data files: Read in the values for NX. * READ( NIN, FMT = * )( NXVAL( I ), I = 1, NNB ) * WRITE( NOUT, FMT = 9991 )'NB: ', ( NBVAL( I ), I = 1, NNB ) WRITE( NOUT, FMT = 9991 )'NX: ', ( NXVAL( I ), I = 1, NNB ) END IF * * Read in NLDA and the values for LDA. * READ( NIN, FMT = * )NLDA IF( NLDA.GT.MXNLDA ) THEN WRITE( NOUT, FMT = 9999 )'LDA', 'NLDA', MXNLDA NLDA = MXNLDA END IF READ( NIN, FMT = * )( LDAVAL( I ), I = 1, NLDA ) WRITE( NOUT, FMT = 9991 )'LDA: ', ( LDAVAL( I ), I = 1, NLDA ) * * Check that LDA >= 1 for all values of LDA. * LDAOK = .TRUE. MAXLDA = 0 DO 80 I = 1, NLDA MAXLDA = MAX( LDAVAL( I ), MAXLDA ) IF( LDAVAL( I ).LE.0 ) THEN WRITE( NOUT, FMT = 9998 )LDAVAL( I ) LDAOK = .FALSE. END IF 80 CONTINUE IF( .NOT.LDAOK ) $ WRITE( NOUT, FMT = * ) * * Check that MAXLDA*MAXN <= LA (for the dense routines). * LDANOK = .TRUE. NEED = MAXLDA*MAXN IF( NEED.GT.LA ) THEN WRITE( NOUT, FMT = 9995 )MAXLDA, MAXN, NEED LDANOK = .FALSE. END IF * * Check that MAXLDA*MAXM + MAXM*MAXK <= 3*LA (for band routines). * LDAMOK = .TRUE. NEED = MAXLDA*MAXM + MAXM*MAXK IF( NEED.GT.3*LA ) THEN NEED = ( NEED+2 ) / 3 WRITE( NOUT, FMT = 9994 )MAXLDA, MAXM, MAXK, NEED LDAMOK = .FALSE. END IF * * Check that MAXN*MAXNB (or MAXN*INCX) <= LA. * NXNBOK = .TRUE. NEED = MAXN*MAXNB IF( NEED.GT.LA ) THEN WRITE( NOUT, FMT = 9996 )MAXN, MAXNB, NEED NXNBOK = .FALSE. END IF * IF( .NOT.( MOK .AND. NOK .AND. LDAOK .AND. LDANOK .AND. NXNBOK ) ) $ THEN WRITE( NOUT, FMT = 9984 ) GO TO 110 END IF IF( .NOT.LDAMOK ) $ WRITE( NOUT, FMT = * ) * * Read the minimum time to time a subroutine. * WRITE( NOUT, FMT = * ) READ( NIN, FMT = * )TIMMIN WRITE( NOUT, FMT = 9993 )TIMMIN WRITE( NOUT, FMT = * ) * * Read the first input line. * READ( NIN, FMT = '(A)', END = 100 )LINE * * If the first record is the special signal 'NONE', then get the * next line but don't time SGEMV. * IF( LSAMEN( 4, LINE, 'NONE' ) ) THEN READ( NIN, FMT = '(A)', END = 100 )LINE ELSE WRITE( NOUT, FMT = 9990 ) * * Time SGEMV and SGEMM. * CALL STIMMV( 'SGEMV ', NN, NVAL, NNB, NBVAL, NLDA, $ LDAVAL, TIMMIN, A( 1, 1 ), LA, A( 1, 2 ), $ A( 1, 3 ), RESLTS, LDR1, LDR2, NOUT ) CALL STIMMM( 'SGEMM ', 'N', NN, NVAL, NLDA, LDAVAL, $ TIMMIN, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), $ RESLTS, LDR1, LDR2, NOUT ) END IF * * Call the appropriate timing routine for each input line. * WRITE( NOUT, FMT = 9988 ) 90 CONTINUE C1 = LINE( 1: 1 ) C2 = LINE( 2: 3 ) C3 = LINE( 4: 6 ) * * Check first character for correct precision. * IF( .NOT.LSAME( C1, 'Sprecision' ) ) THEN WRITE( NOUT, FMT = 9987 )LINE( 1: 6 ) * ELSE IF( LSAMEN( 2, C2, 'QR' ) .OR. LSAMEN( 2, C3, 'QR' ) .OR. $ LSAMEN( 2, C3( 2: 3 ), 'QR' ) ) THEN * * QR routines * CALL STIMQR( LINE, NN, MVAL, NVAL, NK, KVAL, NNB, NBVAL, $ NXVAL, NLDA, LDAVAL, TIMMIN, A( 1, 1 ), D, $ A( 1, 2 ), A( 1, 3 ), RESLTS, LDR1, LDR2, $ LDR3, NOUT ) * ELSE IF( LSAMEN( 2, C2, 'QP' ) .OR. LSAMEN( 3, C3, 'QPF' ) ) THEN * * QR with column pivoting * CALL STIMQP( LINE, NM, MVAL, NVAL, NLDA, LDAVAL, TIMMIN, $ A( 1, 1 ), A( 1, 2 ), D( 1, 1 ), A( 1, 3 ), IWORK, $ RESLTS, LDR1, LDR2, NOUT ) * ELSE IF( LSAMEN( 2, C2, 'RR' ) .OR. LSAMEN( 3, C3, 'RRF' ) ) THEN * * Rank-Revealing QR * CALL STIMRR( LINE, NM, MVAL, NVAL, NK, KVAL, $ NNB, NBVAL, NXVAL, NLDA, LDAVAL, TIMMIN, $ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), A( 1, 4 ), $ IWORK, RESLTS, LDR1, LDR2, NOUT ) * ELSE * WRITE( NOUT, FMT = 9987 )LINE( 1: 6 ) END IF * * Read the next line of the input file. * READ( NIN, FMT = '(A)', END = 100 )LINE GO TO 90 * * Branch to this line when the last record is read. * 100 CONTINUE S2 = SECOND( ) WRITE( NOUT, FMT = 9986 ) WRITE( NOUT, FMT = 9985 )S2 - S1 110 CONTINUE * 9999 FORMAT( ' Too many values of ', A, ' using ', A, ' = ', I2 ) 9998 FORMAT( ' *** LDA = ', I7, ' is too small, must have ', $ 'LDA > 0.' ) 9997 FORMAT( ' *** ', A1, ' = ', I7, ' is too big: ', $ 'maximum allowed is', I7 ) 9996 FORMAT( ' *** N*NB is too big for N =', I6, ', NB =', I6, $ / ' --> Increase LA to at least ', I8 ) 9995 FORMAT( ' *** LDA*N is too big for the dense routines ', '(LDA =', $ I6, ', N =', I6, ')', / ' --> Increase LA to at least ', $ I8 ) 9994 FORMAT( ' *** (LDA+K)*M is too big for the band routines ', $ '(LDA=', I6, ', M=', I6, ', K=', I6, ')', $ / ' --> Increase LA to at least ', I8 ) 9993 FORMAT( ' The minimum time a subroutine will be timed = ', F6.3, $ ' seconds' ) 9992 FORMAT( ' The following parameter values will be used:' ) 9991 FORMAT( 4X, A7, 1X, 10I6, / 12X, 10I6 ) 9990 FORMAT( / ' ------------------------------', $ / ' >>>>> Sample BLAS <<<<<', $ / ' ------------------------------' ) 9988 FORMAT( / ' ------------------------------', $ / ' >>>>> Timing data <<<<<', $ / ' ------------------------------' ) 9987 FORMAT( 1X, A6, ': Unrecognized path or subroutine name', / ) 9986 FORMAT( ' End of tests' ) 9985 FORMAT( ' Total time used = ', F12.2, ' seconds' ) 9984 FORMAT( / ' Tests not done due to input errors' ) * * End of STIMAA * END SHAR_EOF fi # end of overwriting check if test -f 'stimmg.f' then echo shar: will not over-write existing file "'stimmg.f'" else cat << SHAR_EOF > 'stimmg.f' SUBROUTINE STIMMG( IFLAG, M, N, A, LDA, KL, KU ) * * -- LAPACK timing 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 IFLAG, KL, KU, LDA, M, N * .. * .. Array Arguments .. REAL A( LDA, * ) * .. * * Purpose * ======= * * STIMMG generates a real test matrix whose type is given by IFLAG. * All the matrices are Toeplitz (constant along a diagonal), with * random elements on each diagonal. * * Arguments * ========= * * IFLAG (input) INTEGER * The type of matrix to be generated. * = 0 or 1: General matrix * = 2 or -2: General banded matrix * = 3 or -3: Symmetric positive definite matrix * = 4 or -4: Symmetric positive definite packed * = 5 or -5: Symmetric positive definite banded * = 6 or -6: Symmetric indefinite matrix * = 7 or -7: Symmetric indefinite packed * = 8 or -8: Symmetric indefinite banded * = 9 or -9: Triangular * = 10 or -10: Triangular packed * = 11 or -11: Triangular banded * = 12: General tridiagonal * = 13 or -13: Positive definite tridiagonal * For symmetric or triangular matrices, IFLAG > 0 indicates * upper triangular storage and IFLAG < 0 indicates lower * triangular storage. * * M (input) INTEGER * The number of rows of the matrix to be generated. * * N (input) INTEGER * The number of columns of the matrix to be generated. * * A (output) REAL array, dimension (LDA,N) * The generated matrix. * * If the absolute value of IFLAG is 1, 3, or 6, the leading * M x N (or N x N) subblock is used to store the matrix. * If the matrix is symmetric, only the upper or lower triangle * of this block is referenced. * * If the absolute value of IFLAG is 4 or 7, the matrix is * symmetric and packed storage is used for the upper or lower * triangle. The triangular matrix is stored columnwise as a * inear array, and the array A is treated as a vector of * length LDA. LDA must be set to at least N*(N+1)/2. * * If the absolute value of IFLAG is 2 or 5, the matrix is * returned in band format. The columns of the matrix are * specified in the columns of A and the diagonals of the * matrix are specified in the rows of A, with the leading * diagonal in row * KL + KU + 1, if IFLAG = 2 * KU + 1, if IFLAG = 5 or -2 * 1, if IFLAG = -5 * If IFLAG = 2, the first KL rows are not used to leave room * for pivoting in SGBTRF. * * LDA (input) INTEGER * The leading dimension of A. If the generated matrix is * packed, LDA >= N*(N+1)/2, otherwise LDA >= max(1,M). * * KL (input) INTEGER * The number of subdiagonals if IFLAG = 2, 5, or -5. * * KU (input) INTEGER * The number of superdiagonals if IFLAG = 2, 5, or -5. * * ===================================================================== * * .. Local Scalars .. INTEGER I, J, JJ, JN, K, MJ, MU * .. * .. Local Arrays .. INTEGER ISEED( 4 ) * .. * .. Intrinsic Functions .. INTRINSIC MIN, REAL, SIGN * .. * .. External Subroutines .. EXTERNAL SCOPY, SLARNV * .. * .. Data statements .. DATA ISEED / 0, 0, 0, 1 / * .. * .. Executable Statements .. * IF( M.LE.0 .OR. N.LE.0 ) THEN RETURN * ELSE IF( IFLAG.EQ.0 .OR. IFLAG.EQ.1 ) THEN * * General matrix * * Set first column and row to random values. * CALL SLARNV( 2, ISEED, M, A( 1, 1 ) ) DO 10 J = 2, N, M MJ = MIN( M, N-J+1 ) CALL SLARNV( 2, ISEED, MJ, A( 1, J ) ) IF( MJ.GT.1 ) $ CALL SCOPY( MJ-1, A( 2, J ), 1, A( 1, J+1 ), LDA ) 10 CONTINUE * * Fill in the rest of the matrix. * DO 30 J = 2, N DO 20 I = 2, M A( I, J ) = A( I-1, J-1 ) 20 CONTINUE 30 CONTINUE * ELSE IF( IFLAG.EQ.2 .OR. IFLAG.EQ.-2 ) THEN * * General band matrix * IF( IFLAG.EQ.2 ) THEN K = KL + KU + 1 ELSE K = KU + 1 END IF CALL SLARNV( 2, ISEED, MIN( M, KL+1 ), A( K, 1 ) ) MU = MIN( N-1, KU ) CALL SLARNV( 2, ISEED, MU+1, A( K-MU, N ) ) DO 40 J = 2, N - 1 MU = MIN( J-1, KU ) CALL SCOPY( MU, A( K-MU, N ), 1, A( K-MU, J ), 1 ) CALL SCOPY( MIN( M-J+1, KL+1 ), A( K, 1 ), 1, A( K, J ), 1 ) 40 CONTINUE * ELSE IF( IFLAG.EQ.3 ) THEN * * Symmetric positive definite, upper triangle * CALL SLARNV( 2, ISEED, N-1, A( 1, N ) ) A( N, N ) = REAL( N ) DO 50 J = N - 1, 1, -1 CALL SCOPY( J, A( N-J+1, N ), 1, A( 1, J ), 1 ) 50 CONTINUE * ELSE IF( IFLAG.EQ.-3 ) THEN * * Symmetric positive definite, lower triangle * A( 1, 1 ) = REAL( N ) IF( N.GT.1 ) $ CALL SLARNV( 2, ISEED, N-1, A( 2, 1 ) ) DO 60 J = 2, N CALL SCOPY( N-J+1, A( 1, 1 ), 1, A( J, J ), 1 ) 60 CONTINUE * ELSE IF( IFLAG.EQ.4 ) THEN * * Symmetric positive definite packed, upper triangle * JN = ( N-1 )*N / 2 + 1 CALL SLARNV( 2, ISEED, N-1, A( JN, 1 ) ) A( JN+N-1, 1 ) = REAL( N ) JJ = JN DO 70 J = N - 1, 1, -1 JJ = JJ - J JN = JN + 1 CALL SCOPY( J, A( JN, 1 ), 1, A( JJ, 1 ), 1 ) 70 CONTINUE * ELSE IF( IFLAG.EQ.-4 ) THEN * * Symmetric positive definite packed, lower triangle * A( 1, 1 ) = REAL( N ) IF( N.GT.1 ) $ CALL SLARNV( 2, ISEED, N-1, A( 2, 1 ) ) JJ = N + 1 DO 80 J = 2, N CALL SCOPY( N-J+1, A( 1, 1 ), 1, A( JJ, 1 ), 1 ) JJ = JJ + N - J + 1 80 CONTINUE * ELSE IF( IFLAG.EQ.5 ) THEN * * Symmetric positive definite banded, upper triangle * K = KL MU = MIN( N-1, K ) CALL SLARNV( 2, ISEED, MU, A( K+1-MU, N ) ) A( K+1, N ) = REAL( N ) DO 90 J = N - 1, 1, -1 MU = MIN( J, K+1 ) CALL SCOPY( MU, A( K+2-MU, N ), 1, A( K+2-MU, J ), 1 ) 90 CONTINUE * ELSE IF( IFLAG.EQ.-5 ) THEN * * Symmetric positive definite banded, lower triangle * K = KL A( 1, 1 ) = REAL( N ) CALL SLARNV( 2, ISEED, MIN( N-1, K ), A( 2, 1 ) ) DO 100 J = 2, N CALL SCOPY( MIN( N-J+1, K+1 ), A( 1, 1 ), 1, A( 1, J ), 1 ) 100 CONTINUE * ELSE IF( IFLAG.EQ.6 ) THEN * * Symmetric indefinite, upper triangle * CALL SLARNV( 2, ISEED, N, A( 1, N ) ) DO 110 J = N - 1, 1, -1 CALL SCOPY( J, A( N-J+1, N ), 1, A( 1, J ), 1 ) 110 CONTINUE * ELSE IF( IFLAG.EQ.-6 ) THEN * * Symmetric indefinite, lower triangle * CALL SLARNV( 2, ISEED, N, A( 1, 1 ) ) DO 120 J = 2, N CALL SCOPY( N-J+1, A( 1, 1 ), 1, A( J, J ), 1 ) 120 CONTINUE * ELSE IF( IFLAG.EQ.7 ) THEN * * Symmetric indefinite packed, upper triangle * JN = ( N-1 )*N / 2 + 1 CALL SLARNV( 2, ISEED, N, A( JN, 1 ) ) JJ = JN DO 130 J = N - 1, 1, -1 JJ = JJ - J JN = JN + 1 CALL SCOPY( J, A( JN, 1 ), 1, A( JJ, 1 ), 1 ) 130 CONTINUE * ELSE IF( IFLAG.EQ.-7 ) THEN * * Symmetric indefinite packed, lower triangle * CALL SLARNV( 2, ISEED, N, A( 1, 1 ) ) JJ = N + 1 DO 140 J = 2, N CALL SCOPY( N-J+1, A( 1, 1 ), 1, A( JJ, 1 ), 1 ) JJ = JJ + N - J + 1 140 CONTINUE * ELSE IF( IFLAG.EQ.8 ) THEN * * Symmetric indefinite banded, upper triangle * K = KL MU = MIN( N, K+1 ) CALL SLARNV( 2, ISEED, MU, A( K+2-MU, N ) ) DO 150 J = N - 1, 1, -1 MU = MIN( J, K+1 ) CALL SCOPY( MU, A( K+2-MU, N ), 1, A( K+2-MU, J ), 1 ) 150 CONTINUE * ELSE IF( IFLAG.EQ.-8 ) THEN * * Symmetric indefinite banded, lower triangle * K = KL CALL SLARNV( 2, ISEED, MIN( N, K+1 ), A( 1, 1 ) ) DO 160 J = 2, N CALL SCOPY( MIN( N-J+1, K+1 ), A( 1, 1 ), 1, A( 1, J ), 1 ) 160 CONTINUE * ELSE IF( IFLAG.EQ.9 ) THEN * * Upper triangular * CALL SLARNV( 2, ISEED, N, A( 1, N ) ) A( N, N ) = SIGN( REAL( N ), A( N, N ) ) DO 170 J = N - 1, 1, -1 CALL SCOPY( J, A( N-J+1, N ), 1, A( 1, J ), 1 ) 170 CONTINUE * ELSE IF( IFLAG.EQ.-9 ) THEN * * Lower triangular * CALL SLARNV( 2, ISEED, N, A( 1, 1 ) ) A( 1, 1 ) = SIGN( REAL( N ), A( 1, 1 ) ) DO 180 J = 2, N CALL SCOPY( N-J+1, A( 1, 1 ), 1, A( J, J ), 1 ) 180 CONTINUE * ELSE IF( IFLAG.EQ.10 ) THEN * * Upper triangular packed * JN = ( N-1 )*N / 2 + 1 CALL SLARNV( 2, ISEED, N, A( JN, 1 ) ) A( JN+N-1, 1 ) = SIGN( REAL( N ), A( JN+N-1, 1 ) ) JJ = JN DO 190 J = N - 1, 1, -1 JJ = JJ - J JN = JN + 1 CALL SCOPY( J, A( JN, 1 ), 1, A( JJ, 1 ), 1 ) 190 CONTINUE * ELSE IF( IFLAG.EQ.-10 ) THEN * * Lower triangular packed * CALL SLARNV( 2, ISEED, N, A( 1, 1 ) ) A( 1, 1 ) = SIGN( REAL( N ), A( 1, 1 ) ) JJ = N + 1 DO 200 J = 2, N CALL SCOPY( N-J+1, A( 1, 1 ), 1, A( JJ, 1 ), 1 ) JJ = JJ + N - J + 1 200 CONTINUE * ELSE IF( IFLAG.EQ.11 ) THEN * * Upper triangular banded * K = KL MU = MIN( N, K+1 ) CALL SLARNV( 2, ISEED, MU, A( K+2-MU, N ) ) A( K+1, N ) = SIGN( REAL( K+1 ), A( K+1, N ) ) DO 210 J = N - 1, 1, -1 MU = MIN( J, K+1 ) CALL SCOPY( MU, A( K+2-MU, N ), 1, A( K+2-MU, J ), 1 ) 210 CONTINUE * ELSE IF( IFLAG.EQ.-11 ) THEN * * Lower triangular banded * K = KL CALL SLARNV( 2, ISEED, MIN( N, K+1 ), A( 1, 1 ) ) A( 1, 1 ) = SIGN( REAL( K+1 ), A( 1, 1 ) ) DO 220 J = 2, N CALL SCOPY( MIN( N-J+1, K+1 ), A( 1, 1 ), 1, A( 1, J ), 1 ) 220 CONTINUE * ELSE IF( IFLAG.EQ.12 ) THEN * * General tridiagonal * CALL SLARNV( 2, ISEED, 3*N-2, A ) * ELSE IF( IFLAG.EQ.13 .OR. IFLAG.EQ.-13 ) THEN * * Positive definite tridiagonal * DO 230 J = 1, N A( J, 1 ) = 2.0 230 CONTINUE CALL SLARNV( 2, ISEED, N-1, A( N+1, 1 ) ) END IF * RETURN * * End of STIMMG * END SHAR_EOF fi # end of overwriting check if test -f 'stimmm.f' then echo shar: will not over-write existing file "'stimmm.f'" else cat << SHAR_EOF > 'stimmm.f' SUBROUTINE STIMMM( VNAME, LAB2, NN, NVAL, NLDA, LDAVAL, TIMMIN, A, $ B, C, RESLTS, LDR1, LDR2, NOUT ) * * -- LAPACK timing routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER*( * ) LAB2, VNAME INTEGER LDR1, LDR2, NLDA, NN, NOUT REAL TIMMIN * .. * .. Array Arguments .. INTEGER LDAVAL( * ), NVAL( * ) REAL A( * ), B( * ), C( * ), RESLTS( LDR1, LDR2, * ) * .. * * Purpose * ======= * * STIMMM times SGEMM. * * Arguments * ========= * * VNAME (input) CHARACTER*(*) * The name of the Level 3 BLAS routine to be timed. * * LAB2 (input) CHARACTER*(*) * The name of the variable given in NVAL. * * NN (input) INTEGER * The number of values of N contained in the vector NVAL. * * NVAL (input) INTEGER array, dimension (NN) * The values of the matrix dimension N. * * NLDA (input) INTEGER * The number of values of LDA contained in the vector LDAVAL. * * LDAVAL (input) INTEGER array, dimension (NLDA) * The values of the leading dimension of the array A. * * TIMMIN (input) REAL * The minimum time a subroutine will be timed. * * A (workspace) REAL array, dimension (LDAMAX*NMAX) * where LDAMAX and NMAX are the maximum values permitted * for LDA and N. * * B (workspace) REAL array, dimension (LDAMAX*NMAX) * * C (workspace) REAL array, dimension (LDAMAX*NMAX) * * RESLTS (output) REAL array, dimension (LDR1,LDR2,NLDA) * The timing results for each subroutine over the relevant * values of N and LDA. * * LDR1 (input) INTEGER * The first dimension of RESLTS. LDR1 >= 1. * * LDR2 (input) INTEGER * The second dimension of RESLTS. LDR2 >= max(1,NN). * * NOUT (input) INTEGER * The unit number for output. * * ===================================================================== * * .. Parameters .. INTEGER NSUBS REAL ONE PARAMETER ( NSUBS = 1, ONE = 1.0E+0 ) * .. * .. Local Scalars .. CHARACTER*6 CNAME INTEGER I, IC, ICL, ILDA, IN, INFO, ISUB, LDA, N REAL OPS, S1, S2, TIME, UNTIME * .. * .. Local Arrays .. LOGICAL TIMSUB( NSUBS ) CHARACTER*6 SUBNAM( NSUBS ) INTEGER IDUMMY( 1 ) * .. * .. External Functions .. LOGICAL LSAMEN REAL SECOND, SMFLOP, SOPBL3 EXTERNAL LSAMEN, SECOND, SMFLOP, SOPBL3 * .. * .. External Subroutines .. EXTERNAL ATIMCK, SGEMM, SPRTBL, STIMMG * .. * .. Intrinsic Functions .. INTRINSIC REAL * .. * .. Data statements .. DATA SUBNAM / 'SGEMM ' / * .. * .. Executable Statements .. * CNAME = VNAME DO 10 ISUB = 1, NSUBS TIMSUB( ISUB ) = LSAMEN( 6, CNAME, SUBNAM( ISUB ) ) IF( TIMSUB( ISUB ) ) $ GO TO 20 10 CONTINUE WRITE( NOUT, FMT = 9999 )CNAME GO TO 80 20 CONTINUE * * Check that N <= LDA for the input values. * CALL ATIMCK( 2, CNAME, NN, NVAL, NLDA, LDAVAL, NOUT, INFO ) IF( INFO.GT.0 ) THEN WRITE( NOUT, FMT = 9998 )CNAME GO TO 80 END IF * DO 60 ILDA = 1, NLDA LDA = LDAVAL( ILDA ) DO 50 IN = 1, NN N = NVAL( IN ) * * Time SGEMM * CALL STIMMG( 1, N, N, A, LDA, 0, 0 ) CALL STIMMG( 0, N, N, B, LDA, 0, 0 ) CALL STIMMG( 1, N, N, C, LDA, 0, 0 ) IC = 0 S1 = SECOND( ) 30 CONTINUE CALL SGEMM( 'No transpose', 'No transpose', N, N, N, ONE, A, $ LDA, B, LDA, ONE, C, LDA ) S2 = SECOND( ) TIME = S2 - S1 IC = IC + 1 IF( TIME.LT.TIMMIN ) THEN CALL STIMMG( 1, N, N, C, LDA, 0, 0 ) GO TO 30 END IF * * Subtract the time used in STIMMG. * ICL = 1 S1 = SECOND( ) 40 CONTINUE S2 = SECOND( ) UNTIME = S2 - S1 ICL = ICL + 1 IF( ICL.LE.IC ) THEN CALL STIMMG( 1, N, N, C, LDA, 0, 0 ) GO TO 40 END IF * TIME = ( TIME-UNTIME ) / REAL( IC ) OPS = SOPBL3( 'SGEMM ', N, N, N ) RESLTS( 1, IN, ILDA ) = SMFLOP( OPS, TIME, 0 ) 50 CONTINUE 60 CONTINUE * * Print the table of results on unit NOUT. * WRITE( NOUT, FMT = 9997 )VNAME IF( NLDA.EQ.1 ) THEN WRITE( NOUT, FMT = 9996 )LDAVAL( 1 ) ELSE DO 70 I = 1, NLDA WRITE( NOUT, FMT = 9995 )I, LDAVAL( I ) 70 CONTINUE END IF WRITE( NOUT, FMT = * ) CALL SPRTBL( ' ', LAB2, 1, IDUMMY, NN, NVAL, NLDA, RESLTS, LDR1, $ LDR2, NOUT ) * 80 CONTINUE RETURN 9999 FORMAT( 1X, A6, ': Unrecognized path or subroutine name', / ) 9998 FORMAT( 1X, A6, ' timing run not attempted', / ) 9997 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' ) 9996 FORMAT( 5X, 'with LDA = ', I5 ) 9995 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 ) * * End of STIMMM * END SHAR_EOF fi # end of overwriting check if test -f 'stimmv.f' then echo shar: will not over-write existing file "'stimmv.f'" else cat << SHAR_EOF > 'stimmv.f' SUBROUTINE STIMMV( VNAME, NN, NVAL, NK, KVAL, NLDA, LDAVAL, $ TIMMIN, A, LB, B, C, RESLTS, LDR1, LDR2, NOUT ) * * -- LAPACK timing routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER*( * ) VNAME INTEGER LB, LDR1, LDR2, NK, NLDA, NN, NOUT REAL TIMMIN * .. * .. Array Arguments .. INTEGER KVAL( * ), LDAVAL( * ), NVAL( * ) REAL A( * ), B( * ), C( * ), RESLTS( LDR1, LDR2, * ) * .. * * Purpose * ======= * * STIMMV times individual BLAS 2 routines. * * Arguments * ========= * * VNAME (input) CHARACTER*(*) * The name of the Level 2 BLAS routine to be timed. * * NN (input) INTEGER * The number of values of N contained in the vector NVAL. * * NVAL (input) INTEGER array, dimension (NN) * The values of the matrix dimension N. * * NK (input) INTEGER * The number of values of K contained in the vector KVAL. * * KVAL (input) INTEGER array, dimension (NK) * The values of the bandwidth K. * * NLDA (input) INTEGER * The number of values of LDA contained in the vector LDAVAL. * * LDAVAL (input) INTEGER array, dimension (NLDA) * The values of the leading dimension of the array A. * * TIMMIN (input) REAL * The minimum time a subroutine will be timed. * * A (workspace) REAL array, dimension (LDAMAX*NMAX) * where LDAMAX and NMAX are the maximum values permitted * for LDA and N. * * LB (input) INTEGER * The length of B and C, needed when timing SGBMV. If timing * SGEMV, LB >= LDAMAX*NMAX. * * B (workspace) REAL array, dimension (LB) * * C (workspace) REAL array, dimension (LB) * * RESLTS (output) REAL array, dimension (LDR1,LDR2,NLDA) * The timing results for each subroutine over the relevant * values of N and LDA. * * LDR1 (input) INTEGER * The first dimension of RESLTS. LDR1 >= max(1,NK). * * LDR2 (input) INTEGER * The second dimension of RESLTS. LDR2 >= max(1,NN). * * NOUT (input) INTEGER * The unit number for output. * * ===================================================================== * * .. Parameters .. INTEGER NSUBS REAL ONE PARAMETER ( NSUBS = 2, ONE = 1.0E+0 ) * .. * .. Local Scalars .. CHARACTER LAB1, LAB2 CHARACTER*6 CNAME INTEGER I, IB, IC, ICL, IK, ILDA, IN, INFO, ISUB, K, $ KL, KU, LDA, LDB, N, NRHS REAL OPS, S1, S2, TIME, UNTIME * .. * .. Local Arrays .. LOGICAL TIMSUB( NSUBS ) CHARACTER*6 SUBNAM( NSUBS ) * .. * .. External Functions .. LOGICAL LSAME, LSAMEN REAL SECOND, SMFLOP, SOPBL2 EXTERNAL LSAME, LSAMEN, SECOND, SMFLOP, SOPBL2 * .. * .. External Subroutines .. EXTERNAL ATIMCK, SGBMV, SGEMV, SPRTBL, STIMMG * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN, REAL * .. * .. Data statements .. DATA SUBNAM / 'SGEMV ', 'SGBMV ' / * .. * .. Executable Statements .. * CNAME = VNAME DO 10 ISUB = 1, NSUBS TIMSUB( ISUB ) = LSAMEN( 6, CNAME, SUBNAM( ISUB ) ) IF( TIMSUB( ISUB ) ) $ GO TO 20 10 CONTINUE WRITE( NOUT, FMT = 9999 )CNAME GO TO 150 20 CONTINUE * * Check that N or K <= LDA for the input values. * IF( LSAME( CNAME( 3: 3 ), 'B' ) ) THEN CALL ATIMCK( 0, CNAME, NK, KVAL, NLDA, LDAVAL, NOUT, INFO ) LAB1 = 'M' LAB2 = 'K' ELSE CALL ATIMCK( 2, CNAME, NN, NVAL, NLDA, LDAVAL, NOUT, INFO ) LAB1 = ' ' LAB2 = 'N' END IF IF( INFO.GT.0 ) THEN WRITE( NOUT, FMT = 9998 )CNAME GO TO 150 END IF * * Print the table header on unit NOUT. * WRITE( NOUT, FMT = 9997 )VNAME IF( NLDA.EQ.1 ) THEN WRITE( NOUT, FMT = 9996 )LDAVAL( 1 ) ELSE DO 30 I = 1, NLDA WRITE( NOUT, FMT = 9995 )I, LDAVAL( I ) 30 CONTINUE END IF WRITE( NOUT, FMT = * ) * * Time SGEMV * IF( TIMSUB( 1 ) ) THEN DO 80 ILDA = 1, NLDA LDA = LDAVAL( ILDA ) DO 70 IN = 1, NN N = NVAL( IN ) NRHS = N LDB = LDA CALL STIMMG( 1, N, N, A, LDA, 0, 0 ) CALL STIMMG( 0, N, NRHS, B, LDB, 0, 0 ) CALL STIMMG( 1, N, NRHS, C, LDB, 0, 0 ) IC = 0 S1 = SECOND( ) 40 CONTINUE IB = 1 DO 50 I = 1, NRHS CALL SGEMV( 'No transpose', N, N, ONE, A, LDA, $ B( IB ), 1, ONE, C( IB ), 1 ) IB = IB + LDB 50 CONTINUE S2 = SECOND( ) TIME = S2 - S1 IC = IC + 1 IF( TIME.LT.TIMMIN ) THEN CALL STIMMG( 1, N, NRHS, C, LDB, 0, 0 ) GO TO 40 END IF * * Subtract the time used in STIMMG. * ICL = 1 S1 = SECOND( ) 60 CONTINUE S2 = SECOND( ) UNTIME = S2 - S1 ICL = ICL + 1 IF( ICL.LE.IC ) THEN CALL STIMMG( 1, N, NRHS, C, LDB, 0, 0 ) GO TO 60 END IF * TIME = ( TIME-UNTIME ) / REAL( IC ) OPS = NRHS*SOPBL2( 'SGEMV ', N, N, 0, 0 ) RESLTS( 1, IN, ILDA ) = SMFLOP( OPS, TIME, 0 ) 70 CONTINUE 80 CONTINUE * CALL SPRTBL( LAB1, LAB2, 1, NVAL, NN, NVAL, NLDA, RESLTS, LDR1, $ LDR2, NOUT ) * ELSE IF( TIMSUB( 2 ) ) THEN * * Time SGBMV * DO 140 ILDA = 1, NLDA LDA = LDAVAL( ILDA ) DO 130 IN = 1, NN N = NVAL( IN ) DO 120 IK = 1, NK K = MIN( N-1, MAX( 0, KVAL( IK ) ) ) KL = K KU = K LDB = N CALL STIMMG( 2, N, N, A, LDA, KL, KU ) NRHS = MIN( K, LB / LDB ) CALL STIMMG( 0, N, NRHS, B, LDB, 0, 0 ) CALL STIMMG( 1, N, NRHS, C, LDB, 0, 0 ) IC = 0 S1 = SECOND( ) 90 CONTINUE IB = 1 DO 100 I = 1, NRHS CALL SGBMV( 'No transpose', N, N, KL, KU, ONE, $ A( KU+1 ), LDA, B( IB ), 1, ONE, $ C( IB ), 1 ) IB = IB + LDB 100 CONTINUE S2 = SECOND( ) TIME = S2 - S1 IC = IC + 1 IF( TIME.LT.TIMMIN ) THEN CALL STIMMG( 1, N, NRHS, C, LDB, 0, 0 ) GO TO 90 END IF * * Subtract the time used in STIMMG. * ICL = 1 S1 = SECOND( ) 110 CONTINUE S2 = SECOND( ) UNTIME = S2 - S1 ICL = ICL + 1 IF( ICL.LE.IC ) THEN CALL STIMMG( 1, N, NRHS, C, LDB, 0, 0 ) GO TO 110 END IF * TIME = ( TIME-UNTIME ) / REAL( IC ) OPS = NRHS*SOPBL2( 'SGBMV ', N, N, KL, KU ) RESLTS( IN, IK, ILDA ) = SMFLOP( OPS, TIME, 0 ) 120 CONTINUE 130 CONTINUE 140 CONTINUE * CALL SPRTBL( LAB1, LAB2, NN, NVAL, NK, KVAL, NLDA, RESLTS, $ LDR1, LDR2, NOUT ) END IF * 150 CONTINUE 9999 FORMAT( 1X, A6, ': Unrecognized path or subroutine name', / ) 9998 FORMAT( 1X, A6, ' timing run not attempted', / ) 9997 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' ) 9996 FORMAT( 5X, 'with LDA = ', I5 ) 9995 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 ) RETURN * * End of STIMMV * END SHAR_EOF fi # end of overwriting check if test -f 'stimqp.f' then echo shar: will not over-write existing file "'stimqp.f'" else cat << SHAR_EOF > 'stimqp.f' SUBROUTINE STIMQP( LINE, NM, MVAL, NVAL, NLDA, LDAVAL, TIMMIN, A, $ COPYA, TAU, WORK, IWORK, RESLTS, LDR1, LDR2, $ NOUT ) * * -- LAPACK timing routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER*80 LINE INTEGER LDR1, LDR2, NLDA, NM, NOUT REAL TIMMIN * .. * .. Array Arguments .. INTEGER IWORK( * ), LDAVAL( * ), MVAL( * ), NVAL( * ) REAL A( * ), COPYA( * ), RESLTS( LDR1, LDR2, * ), $ TAU( * ), WORK( * ) * .. * * Purpose * ======= * * STIMQP times the LAPACK routines to perform the QR factorization with * column pivoting of a REAL general matrix. * * Two matrix types may be used for timing. The number of types is * set in the parameter NMODE and the matrix types are set in the vector * MODES, using the following key: * 2. BREAK1 D(1:N-1)=1 and D(N)=1.0/COND in SLATMS * 3. GEOM D(I)=COND**(-(I-1)/(N-1)) in SLATMS * These numbers are chosen to correspond with the matrix types in the * test code. * * Arguments * ========= * * LINE (input) CHARACTER*80 * The input line that requested this routine. The first six * characters contain either the name of a subroutine or a * generic path name. The remaining characters may be used to * specify the individual routines to be timed. See ATIMIN for * a full description of the format of the input line. * * NM (input) INTEGER * The number of values of M and N contained in the vectors * MVAL and NVAL. The matrix sizes are used in pairs (M,N). * * MVAL (input) INTEGER array, dimension (NM) * The values of the matrix row dimension M. * * NVAL (input) INTEGER array, dimension (NM) * The values of the matrix column dimension N. * * NLDA (input) INTEGER * The number of values of LDA contained in the vector LDAVAL. * * LDAVAL (input) INTEGER array, dimension (NLDA) * The values of the leading dimension of the array A. * * TIMMIN (input) REAL * The minimum time a subroutine will be timed. * * A (workspace) REAL array, dimension (LDAMAX*NMAX) * where LDAMAX and NMAX are the maximum values of LDA and N. * * COPYA (workspace) REAL array, dimension (LDAMAX*NMAX) * * TAU (workspace) REAL array, dimension (min(M,N)) * * WORK (workspace) REAL array, dimension (3*NMAX) * * IWORK (workspace) INTEGER array, dimension (2*NMAX) * * RESLTS (workspace) REAL array, dimension * (LDR1,LDR2,NLDA) * The timing results for each subroutine over the relevant * values of MODE, (M,N), and LDA. * * LDR1 (input) INTEGER * The first dimension of RESLTS. LDR1 >= max(1,NM). * * LDR2 (input) INTEGER * The second dimension of RESLTS. LDR2 >= max(1,NM). * * NOUT (input) INTEGER * The unit number for output. * * ===================================================================== * * .. Parameters .. INTEGER NSUBS, NMODE PARAMETER ( NSUBS = 1, NMODE = 2 ) REAL ONE PARAMETER ( ONE = 1.0E+0 ) * .. * .. Local Scalars .. CHARACTER*3 PATH CHARACTER*6 CNAME INTEGER I, IC, ICL, ILDA, IM, IMODE, INFO, LDA, M, $ MINMN, MODE, N, NB REAL COND, DMAX, OPS, S1, S2, TIME, UNTIME * .. * .. Local Arrays .. LOGICAL TIMSUB( NSUBS ) CHARACTER*6 SUBNAM( NSUBS ) INTEGER ISEED( 4 ), MODES( NMODE ) * .. * .. External Functions .. REAL SECOND, SLAMCH, SMFLOP, SOPLA EXTERNAL SECOND, SLAMCH, SMFLOP, SOPLA * .. * .. External Subroutines .. EXTERNAL ATIMCK, ATIMIN, ICOPY, SGEQPF, SLACPY, SLATMS, $ SPRTB5 * .. * .. Intrinsic Functions .. INTRINSIC MIN, REAL * .. * .. Data statements .. DATA SUBNAM / 'SGEQPF' / DATA MODES / 2, 3 / DATA ISEED / 0, 0, 0, 1 / * .. * .. Executable Statements .. * * Extract the timing request from the input line. * PATH( 1: 1 ) = 'Single precision' PATH( 2: 3 ) = 'QP' CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO ) IF( .NOT.TIMSUB( 1 ) .OR. INFO.NE.0 ) $ GO TO 90 * * Check that M <= LDA for the input values. * CNAME = LINE( 1: 6 ) CALL ATIMCK( 1, CNAME, NM, MVAL, NLDA, LDAVAL, NOUT, INFO ) IF( INFO.GT.0 ) THEN WRITE( NOUT, FMT = 9999 )CNAME GO TO 90 END IF * * Set the condition number and scaling factor for the matrices * to be generated. * DMAX = ONE COND = ONE / SLAMCH( 'Precision' ) * * Do for each pair of values (M,N): * DO 60 IM = 1, NM M = MVAL( IM ) N = NVAL( IM ) MINMN = MIN( M, N ) * * Do for each value of LDA: * DO 50 ILDA = 1, NLDA LDA = LDAVAL( ILDA ) DO 40 IMODE = 1, NMODE MODE = MODES( IMODE ) * * Generate a test matrix of size m by n using the * singular value distribution indicated by MODE. * DO 10 I = 1, N IWORK( N+I ) = 0 10 CONTINUE CALL SLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', TAU, $ MODE, COND, DMAX, M, N, 'No packing', COPYA, $ LDA, WORK, INFO ) * * SGEQPF: QR factorization with column pivoting * CALL SLACPY( 'All', M, N, COPYA, LDA, A, LDA ) CALL ICOPY( N, IWORK( N+1 ), 1, IWORK, 1 ) IC = 0 S1 = SECOND( ) 20 CONTINUE CALL SGEQPF( M, N, A, LDA, IWORK, TAU, WORK, INFO ) S2 = SECOND( ) TIME = S2 - S1 IC = IC + 1 IF( TIME.LT.TIMMIN ) THEN CALL SLACPY( 'All', M, N, COPYA, LDA, A, LDA ) CALL ICOPY( N, IWORK( N+1 ), 1, IWORK, 1 ) GO TO 20 END IF * * Subtract the time used in SLACPY and ICOPY. * ICL = 1 S1 = SECOND( ) 30 CONTINUE S2 = SECOND( ) UNTIME = S2 - S1 ICL = ICL + 1 IF( ICL.LE.IC ) THEN CALL SLACPY( 'All', M, N, COPYA, LDA, A, LDA ) CALL ICOPY( N, IWORK( N+1 ), 1, IWORK, 1 ) GO TO 30 END IF * TIME = ( TIME-UNTIME ) / REAL( IC ) OPS = SOPLA( 'SGEQPF', M, N, 0, 0, NB ) RESLTS( IMODE, IM, ILDA ) = SMFLOP( OPS, TIME, INFO ) * 40 CONTINUE 50 CONTINUE 60 CONTINUE * * Print tables of results * WRITE( NOUT, FMT = 9998 )SUBNAM( 1 ) IF( NLDA.GT.1 ) THEN DO 70 I = 1, NLDA WRITE( NOUT, FMT = 9997 )I, LDAVAL( I ) 70 CONTINUE END IF WRITE( NOUT, FMT = * ) CALL SPRTB5( 'Type', 'M', 'N', NMODE, MODES, NM, MVAL, NVAL, NLDA, $ RESLTS, LDR1, LDR2, NOUT ) 90 CONTINUE 9999 FORMAT( 1X, A6, ' timing run not attempted', / ) 9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' ) 9997 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 ) RETURN * * End of STIMQP * END SHAR_EOF fi # end of overwriting check if test -f 'stimqr.f' then echo shar: will not over-write existing file "'stimqr.f'" else cat << SHAR_EOF > 'stimqr.f' SUBROUTINE STIMQR( LINE, NM, MVAL, NVAL, NK, KVAL, NNB, NBVAL, $ NXVAL, NLDA, LDAVAL, TIMMIN, A, TAU, B, WORK, $ RESLTS, LDR1, LDR2, LDR3, NOUT ) * * -- LAPACK timing routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER*80 LINE INTEGER LDR1, LDR2, LDR3, NK, NLDA, NM, NNB, NOUT REAL TIMMIN * .. * .. Array Arguments .. INTEGER KVAL( * ), LDAVAL( * ), MVAL( * ), NBVAL( * ), $ NVAL( * ), NXVAL( * ) REAL A( * ), B( * ), RESLTS( LDR1, LDR2, LDR3, * ), $ TAU( * ), WORK( * ) * .. * * Purpose * ======= * * STIMQR times the LAPACK routines to perform the QR factorization of * a REAL general matrix. * * Arguments * ========= * * LINE (input) CHARACTER*80 * The input line that requested this routine. The first six * characters contain either the name of a subroutine or a * generic path name. The remaining characters may be used to * specify the individual routines to be timed. See ATIMIN for * a full description of the format of the input line. * * NM (input) INTEGER * The number of values of M and N contained in the vectors * MVAL and NVAL. The matrix sizes are used in pairs (M,N). * * MVAL (input) INTEGER array, dimension (NM) * The values of the matrix row dimension M. * * NVAL (input) INTEGER array, dimension (NM) * The values of the matrix column dimension N. * * NK (input) INTEGER * The number of values of K in the vector KVAL. * * KVAL (input) INTEGER array, dimension (NK) * The values of the matrix dimension K, used in SORMQR. * * NNB (input) INTEGER * The number of values of NB and NX contained in the * vectors NBVAL and NXVAL. The blocking parameters are used * in pairs (NB,NX). * * NBVAL (input) INTEGER array, dimension (NNB) * The values of the blocksize NB. * * NXVAL (input) INTEGER array, dimension (NNB) * The values of the crossover point NX. * * NLDA (input) INTEGER * The number of values of LDA contained in the vector LDAVAL. * * LDAVAL (input) INTEGER array, dimension (NLDA) * The values of the leading dimension of the array A. * * TIMMIN (input) REAL * The minimum time a subroutine will be timed. * * A (workspace) REAL array, dimension (LDAMAX*NMAX) * where LDAMAX and NMAX are the maximum values of LDA and N. * * TAU (workspace) REAL array, dimension (min(M,N)) * * B (workspace) REAL array, dimension (LDAMAX*NMAX) * * WORK (workspace) REAL array, dimension (LDAMAX*NBMAX) * where NBMAX is the maximum value of NB. * * RESLTS (workspace) REAL array, dimension * (LDR1,LDR2,LDR3,2*NK) * The timing results for each subroutine over the relevant * values of (M,N), (NB,NX), and LDA. * * LDR1 (input) INTEGER * The first dimension of RESLTS. LDR1 >= max(1,NNB). * * LDR2 (input) INTEGER * The second dimension of RESLTS. LDR2 >= max(1,NM). * * LDR3 (input) INTEGER * The third dimension of RESLTS. LDR3 >= max(1,NLDA). * * NOUT (input) INTEGER * The unit number for output. * * Internal Parameters * =================== * * MODE INTEGER * The matrix type. MODE = 3 is a geometric distribution of * eigenvalues. See SLATMS for further details. * * COND REAL * The condition number of the matrix. The singular values are * set to values from DMAX to DMAX/COND. * * DMAX REAL * The magnitude of the largest singular value. * * ===================================================================== * * .. Parameters .. INTEGER NSUBS PARAMETER ( NSUBS = 3 ) INTEGER MODE REAL COND, DMAX PARAMETER ( MODE = 3, COND = 100.0E0, DMAX = 1.0E0 ) * .. * .. Local Scalars .. CHARACTER LABM, SIDE, TRANS CHARACTER*3 PATH CHARACTER*6 CNAME INTEGER I, I4, IC, ICL, IK, ILDA, IM, IMX, INB, INFO, $ ISIDE, ISUB, ITOFF, ITRAN, K, K1, LDA, LW, M, $ M1, MINMN, N, N1, NB, NX REAL OPS, S1, S2, TIME, UNTIME * .. * .. Local Arrays .. LOGICAL TIMSUB( NSUBS ) CHARACTER SIDES( 2 ), TRANSS( 2 ) CHARACTER*6 SUBNAM( NSUBS ) INTEGER ISEED( 4 ), MUSE( 12 ), NUSE( 12 ), RESEED( 4 ) * .. * .. External Functions .. REAL SECOND, SMFLOP, SOPLA EXTERNAL SECOND, SMFLOP, SOPLA * .. * .. External Subroutines .. EXTERNAL ATIMCK, ATIMIN, ICOPY, SGEQRF, SLACPY, SLATMS, $ SORGQR, SORMQR, SPRTB4, SPRTB5, STIMMG, XLAENV * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN, REAL * .. * .. Data statements .. DATA SUBNAM / 'SGEQRF', 'SORGQR', 'SORMQR' / DATA SIDES / 'L', 'R' / , TRANSS / 'N', 'T' / DATA ISEED / 0, 0, 0, 1 / * .. * .. Executable Statements .. * * Extract the timing request from the input line. * PATH( 1: 1 ) = 'Single precision' PATH( 2: 3 ) = 'QR' CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO ) IF( INFO.NE.0 ) $ GO TO 230 * * Check that M <= LDA for the input values. * CNAME = LINE( 1: 6 ) CALL ATIMCK( 1, CNAME, NM, MVAL, NLDA, LDAVAL, NOUT, INFO ) IF( INFO.GT.0 ) THEN WRITE( NOUT, FMT = 9999 )CNAME GO TO 230 END IF * * Do for each pair of values (M,N): * DO 70 IM = 1, NM M = MVAL( IM ) N = NVAL( IM ) MINMN = MIN( M, N ) CALL ICOPY( 4, ISEED, 1, RESEED, 1 ) * * Do for each value of LDA: * DO 60 ILDA = 1, NLDA LDA = LDAVAL( ILDA ) * * Do for each pair of values (NB, NX) in NBVAL and NXVAL. * DO 50 INB = 1, NNB NB = NBVAL( INB ) CALL XLAENV( 1, NB ) NX = NXVAL( INB ) CALL XLAENV( 3, NX ) LW = MAX( 1, N*MAX( 1, NB ) ) * * Generate a test matrix of size M by N. * CALL ICOPY( 4, RESEED, 1, ISEED, 1 ) CALL SLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', TAU, $ MODE, COND, DMAX, M, N, 'No packing', B, $ LDA, WORK, INFO ) * IF( TIMSUB( 1 ) ) THEN * * SGEQRF: QR factorization * CALL SLACPY( 'Full', M, N, B, LDA, A, LDA ) IC = 0 S1 = SECOND( ) 10 CONTINUE CALL SGEQRF( M, N, A, LDA, TAU, WORK, LW, INFO ) S2 = SECOND( ) TIME = S2 - S1 IC = IC + 1 IF( TIME.LT.TIMMIN ) THEN CALL SLACPY( 'Full', M, N, B, LDA, A, LDA ) GO TO 10 END IF * * Subtract the time used in SLACPY. * ICL = 1 S1 = SECOND( ) 20 CONTINUE S2 = SECOND( ) UNTIME = S2 - S1 ICL = ICL + 1 IF( ICL.LE.IC ) THEN CALL SLACPY( 'Full', M, N, A, LDA, B, LDA ) GO TO 20 END IF * TIME = ( TIME-UNTIME ) / REAL( IC ) OPS = SOPLA( 'SGEQRF', M, N, 0, 0, NB ) RESLTS( INB, IM, ILDA, 1 ) = SMFLOP( OPS, TIME, INFO ) ELSE * * If SGEQRF was not timed, generate a matrix and factor * it using SGEQRF anyway so that the factored form of * the matrix can be used in timing the other routines. * CALL SLACPY( 'Full', M, N, B, LDA, A, LDA ) CALL SGEQRF( M, N, A, LDA, TAU, WORK, LW, INFO ) END IF * IF( TIMSUB( 2 ) ) THEN * * SORGQR: Generate orthogonal matrix Q from the QR * factorization * CALL SLACPY( 'Full', M, MINMN, A, LDA, B, LDA ) IC = 0 S1 = SECOND( ) 30 CONTINUE CALL SORGQR( M, MINMN, MINMN, B, LDA, TAU, WORK, LW, $ INFO ) S2 = SECOND( ) TIME = S2 - S1 IC = IC + 1 IF( TIME.LT.TIMMIN ) THEN CALL SLACPY( 'Full', M, MINMN, A, LDA, B, LDA ) GO TO 30 END IF * * Subtract the time used in SLACPY. * ICL = 1 S1 = SECOND( ) 40 CONTINUE S2 = SECOND( ) UNTIME = S2 - S1 ICL = ICL + 1 IF( ICL.LE.IC ) THEN CALL SLACPY( 'Full', M, MINMN, A, LDA, B, LDA ) GO TO 40 END IF * TIME = ( TIME-UNTIME ) / REAL( IC ) OPS = SOPLA( 'SORGQR', M, MINMN, MINMN, 0, NB ) RESLTS( INB, IM, ILDA, 2 ) = SMFLOP( OPS, TIME, INFO ) END IF * 50 CONTINUE 60 CONTINUE 70 CONTINUE * * Print tables of results * DO 90 ISUB = 1, NSUBS - 1 IF( .NOT.TIMSUB( ISUB ) ) $ GO TO 90 WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB ) IF( NLDA.GT.1 ) THEN DO 80 I = 1, NLDA WRITE( NOUT, FMT = 9997 )I, LDAVAL( I ) 80 CONTINUE END IF WRITE( NOUT, FMT = * ) IF( ISUB.EQ.2 ) $ WRITE( NOUT, FMT = 9996 ) CALL SPRTB4( '( NB, NX)', 'M', 'N', NNB, NBVAL, NXVAL, NM, $ MVAL, NVAL, NLDA, RESLTS( 1, 1, 1, ISUB ), LDR1, $ LDR2, NOUT ) 90 CONTINUE * * Time SORMQR separately. Here the starting matrix is M by N, and * K is the free dimension of the matrix multiplied by Q. * IF( TIMSUB( 3 ) ) THEN * * Check that K <= LDA for the input values. * CALL ATIMCK( 3, CNAME, NK, KVAL, NLDA, LDAVAL, NOUT, INFO ) IF( INFO.GT.0 ) THEN WRITE( NOUT, FMT = 9999 )SUBNAM( 3 ) GO TO 230 END IF * * Use only the pairs (M,N) where M >= N. * IMX = 0 DO 100 IM = 1, NM IF( MVAL( IM ).GE.NVAL( IM ) ) THEN IMX = IMX + 1 MUSE( IMX ) = MVAL( IM ) NUSE( IMX ) = NVAL( IM ) END IF 100 CONTINUE * * SORMQR: Multiply by Q stored as a product of elementary * transformations * * Do for each pair of values (M,N): * DO 180 IM = 1, IMX M = MUSE( IM ) N = NUSE( IM ) * * Do for each value of LDA: * DO 170 ILDA = 1, NLDA LDA = LDAVAL( ILDA ) * * Generate an M by N matrix and form its QR decomposition. * CALL SLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', TAU, $ MODE, COND, DMAX, M, N, 'No packing', A, $ LDA, WORK, INFO ) LW = MAX( 1, N*MAX( 1, NB ) ) CALL SGEQRF( M, N, A, LDA, TAU, WORK, LW, INFO ) * * Do first for SIDE = 'L', then for SIDE = 'R' * I4 = 0 DO 160 ISIDE = 1, 2 SIDE = SIDES( ISIDE ) * * Do for each pair of values (NB, NX) in NBVAL and * NXVAL. * DO 150 INB = 1, NNB NB = NBVAL( INB ) CALL XLAENV( 1, NB ) NX = NXVAL( INB ) CALL XLAENV( 3, NX ) * * Do for each value of K in KVAL * DO 140 IK = 1, NK K = KVAL( IK ) * * Sort out which variable is which * IF( ISIDE.EQ.1 ) THEN M1 = M K1 = N N1 = K LW = MAX( 1, N1*MAX( 1, NB ) ) ELSE N1 = M K1 = N M1 = K LW = MAX( 1, M1*MAX( 1, NB ) ) END IF * * Do first for TRANS = 'N', then for TRANS = 'T' * ITOFF = 0 DO 130 ITRAN = 1, 2 TRANS = TRANSS( ITRAN ) CALL STIMMG( 0, M1, N1, B, LDA, 0, 0 ) IC = 0 S1 = SECOND( ) 110 CONTINUE CALL SORMQR( SIDE, TRANS, M1, N1, K1, A, LDA, $ TAU, B, LDA, WORK, LW, INFO ) S2 = SECOND( ) TIME = S2 - S1 IC = IC + 1 IF( TIME.LT.TIMMIN ) THEN CALL STIMMG( 0, M1, N1, B, LDA, 0, 0 ) GO TO 110 END IF * * Subtract the time used in STIMMG. * ICL = 1 S1 = SECOND( ) 120 CONTINUE S2 = SECOND( ) UNTIME = S2 - S1 ICL = ICL + 1 IF( ICL.LE.IC ) THEN CALL STIMMG( 0, M1, N1, B, LDA, 0, 0 ) GO TO 120 END IF * TIME = ( TIME-UNTIME ) / REAL( IC ) OPS = SOPLA( 'SORMQR', M1, N1, K1, ISIDE-1, $ NB ) RESLTS( INB, IM, ILDA, $ I4+ITOFF+IK ) = SMFLOP( OPS, TIME, INFO ) ITOFF = NK 130 CONTINUE 140 CONTINUE 150 CONTINUE I4 = 2*NK 160 CONTINUE 170 CONTINUE 180 CONTINUE * * Print tables of results * ISUB = 3 I4 = 1 IF( IMX.GE.1 ) THEN DO 220 ISIDE = 1, 2 SIDE = SIDES( ISIDE ) IF( ISIDE.EQ.1 ) THEN WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB ) IF( NLDA.GT.1 ) THEN DO 190 I = 1, NLDA WRITE( NOUT, FMT = 9997 )I, LDAVAL( I ) 190 CONTINUE END IF END IF DO 210 ITRAN = 1, 2 TRANS = TRANSS( ITRAN ) DO 200 IK = 1, NK IF( ISIDE.EQ.1 ) THEN N = KVAL( IK ) WRITE( NOUT, FMT = 9995 )SUBNAM( ISUB ), SIDE, $ TRANS, 'N', N LABM = 'M' ELSE M = KVAL( IK ) WRITE( NOUT, FMT = 9995 )SUBNAM( ISUB ), SIDE, $ TRANS, 'M', M LABM = 'N' END IF CALL SPRTB5( 'NB', LABM, 'K', NNB, NBVAL, IMX, $ MUSE, NUSE, NLDA, $ RESLTS( 1, 1, 1, I4 ), LDR1, LDR2, $ NOUT ) I4 = I4 + 1 200 CONTINUE 210 CONTINUE 220 CONTINUE ELSE WRITE( NOUT, FMT = 9994 )SUBNAM( ISUB ) END IF END IF 230 CONTINUE 9999 FORMAT( 1X, A6, ' timing run not attempted', / ) 9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' ) 9997 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 ) 9996 FORMAT( 5X, 'K = min(M,N)', / ) 9995 FORMAT( / 5X, A6, ' with SIDE = ''', A1, ''', TRANS = ''', A1, $ ''', ', A1, ' =', I6, / ) 9994 FORMAT( ' *** No pairs (M,N) found with M >= N: ', A6, $ ' not timed' ) RETURN * * End of STIMQR * END SHAR_EOF fi # end of overwriting check if test -f 'stimrr.f' then echo shar: will not over-write existing file "'stimrr.f'" else cat << SHAR_EOF > 'stimrr.f' SUBROUTINE STIMRR( LINE, NM, MVAL, NVAL, NK, KVAL, NNB, $ NBVAL, NXVAL, NLDA, LDAVAL, TIMMIN, $ A, COPYA, B, WORK, IWORK, RESLTS, LDR1, $ LDR2, NOUT ) * * -- LAPACK timing routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * Rewritten to time rrqr code. * * .. Scalar Arguments .. CHARACTER*80 LINE INTEGER LDR1, LDR2, NK, NLDA, NM, NNB, NOUT REAL TIMMIN * .. * .. Array Arguments .. INTEGER IWORK( * ), KVAL( * ), LDAVAL( * ), MVAL( * ), $ NBVAL( * ), NVAL( * ), NXVAL( * ) $ REAL A( * ), COPYA( * ), RESLTS( LDR1, LDR2, * ), $ B( * ), WORK( * ) * .. * * Purpose * ======= * * STIMRR times the routines to perform the Rank-Revealing QR * factorization of a REAL general matrix. * * Two matrix types may be used for timing. The number of types is * set in the parameter NMODE and the matrix types are set in the vector * MODES, using the following key: * 2. BREAK1 D(1:N-1)=1 and D(N)=1.0/COND in SLATMS * 3. GEOM D(I)=COND**(-(I-1)/(N-1)) in SLATMS * These numbers are chosen to correspond with the matrix types in the * test code. * * Arguments * ========= * * LINE (input) CHARACTER*80 * The input line that requested this routine. The first six * characters contain either the name of a subroutine or a * generic path name. The remaining characters may be used to * specify the individual routines to be timed. See ATIMIN for * a full description of the format of the input line. * * NM (input) INTEGER * The number of values of M and N contained in the vectors * MVAL and NVAL. The matrix sizes are used in pairs (M,N). * * MVAL (input) INTEGER array, dimension (NM) * The values of the matrix row dimension M. * * NVAL (input) INTEGER array, dimension (NM) * The values of the matrix column dimension N. * * NK (input) INTEGER * The number of values of K in the vector KVAL. * * KVAL (input) INTEGER array, dimension (NK) * The values of the matrix dimension K, used in SORMQR. * * NNB (input) INTEGER * The number of values of NB and NX contained in the * vectors NBVAL and NXVAL. The blocking parameters are used * in pairs (NB,NX). * * NBVAL (input) INTEGER array, dimension (NNB) * The values of the blocksize NB. * * NXVAL (input) INTEGER array, dimension (NNB) * The values of the crossover point NX. * * NLDA (input) INTEGER * The number of values of LDA contained in the vector LDAVAL. * * LDAVAL (input) INTEGER array, dimension (NLDA) * The values of the leading dimension of the array A. * * TIMMIN (input) REAL * The minimum time a subroutine will be timed. * * A (workspace) REAL array, dimension (LDAMAX*NMAX) * where LDAMAX and NMAX are the maximum values of LDA and N. * * COPYA (workspace) REAL array, dimension (LDAMAX*NMAX) * * B (workspace) REAL array, dimension (LDAMAX*NMAX) * * WORK (workspace) REAL array, dimension (3*NMAX) * * IWORK (workspace) INTEGER array, dimension (NMAX) * * RESLTS (workspace) REAL array, dimension * (LDR1,LDR2,NLDA) * The timing results for each subroutine over the relevant * values of MODE, (M,N), and LDA. * * LDR1 (input) INTEGER * The first dimension of RESLTS. LDR1 >= max(1,NM). * * LDR2 (input) INTEGER * The second dimension of RESLTS. LDR2 >= max(1,NM). * * NOUT (input) INTEGER * The unit number for output. * * ===================================================================== * * .. Parameters .. INTEGER NSUBS, NMODE PARAMETER ( NSUBS = 2, NMODE = 2 ) REAL ONE PARAMETER ( ONE = 1.0E+0 ) * .. * .. Local Scalars .. CHARACTER*3 PATH CHARACTER*6 CNAME INTEGER I, IC, ICL, IK, ILDA, IM, IMODE, INB, INFO, $ JOB, K, LDA, LW, M, MINMN, MODE, N, NB, NX, $ RANK REAL COND, DMAX, OPS, IRCOND, ORCOND, S1, S2, $ TIME, UNTIME * .. * .. Local Arrays .. LOGICAL TIMSUB( NSUBS ) CHARACTER*6 SUBNAM( NSUBS ) INTEGER ISEED( 4 ), MODES( NMODE ) REAL SVLUES( 4 ) * .. * .. External Functions .. REAL SLAMCH, SMFLOP, SOPLA, SECOND EXTERNAL SLAMCH, SMFLOP, SOPLA, SECOND * .. * .. External Subroutines .. EXTERNAL ATIMCK, ATIMIN, SGEQPX, SGEQPY, $ SLACPY, SLATMS * .. * .. Intrinsic Functions .. INTRINSIC REAL, MIN * .. * .. Data statements .. DATA SUBNAM / 'SGEQPX', 'SGEQPY' / DATA MODES / 2, 3 / DATA ISEED / 0, 0, 0, 1 / * .. * .. Executable Statements .. * * Extract the timing request from the input line. * PATH( 1: 1 ) = 'Sprecision' PATH( 2: 3 ) = 'RR' CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO ) IF( .NOT.TIMSUB( 1 ) .OR. INFO.NE.0 ) $ GO TO 1000 * * Check that M <= LDA for the input values. * CNAME = LINE( 1: 6 ) CALL ATIMCK( 1, CNAME, NM, MVAL, NLDA, LDAVAL, NOUT, INFO ) IF( INFO.GT.0 ) THEN WRITE( NOUT, FMT = 9999 )CNAME GO TO 1000 END IF * * Set the condition number and scaling factor for the matrices * to be generated. * DMAX = ONE IRCOND = SLAMCH( 'Precision' ) COND = ONE / IRCOND * * Do for each value of K: * DO 10 IK = 1, NK K = KVAL( IK ) IF( K.EQ.0 ) THEN JOB = 1 ELSE JOB = 2 END IF * * Do for each type of matrix: * DO 20 IMODE = 1, NMODE MODE = MODES( IMODE ) * * * ***************** * * Timing xGEQPX * * ***************** * * Do for each value of LDA: * DO 30 ILDA = 1, NLDA LDA = LDAVAL( ILDA ) * * Do for each pair of values (M,N): * DO 40 IM = 1, NM M = MVAL( IM ) N = NVAL( IM ) MINMN = MIN( M, N ) * * Generate a test matrix of size m by n using the * singular value distribution indicated by MODE. * CALL SLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', $ B, MODE, COND, DMAX, M, N, $ 'No packing', COPYA, LDA, WORK, INFO ) * * Do for each pair of values (NB,NX) in NBVAL and NXVAL: * DO 50 INB = 1, NNB NB = NBVAL( INB ) CALL XLAENV( 1, NB ) NX = NXVAL( INB ) CALL XLAENV( 3, NX ) * IF( JOB.EQ.1 ) THEN IF( NB.LT.3 ) THEN LW = MAX( 1, 2*MINMN+3*N ) ELSE LW = MAX( 1, 2*MINMN+NB*N ) END IF ELSE IF( NB.LT.3 ) THEN LW = MAX( 1, 2*MINMN+2*N+MAX(K,N) ) ELSE LW = MAX( 1, 2*MINMN+NB*NB+NB*MAX(K,N) ) END IF END IF * * SGEQPX: Rank-Revealing QR factorization * CALL SLACPY( 'All', M, N, COPYA, LDA, A, LDA ) IC = 0 S1 = SECOND( ) 110 CONTINUE * CALL SGEQPX( JOB, M, N, K, A, LDA, B, LDA, $ IWORK, IRCOND, ORCOND, RANK, SVLUES, $ WORK, LW, INFO ) S2 = SECOND( ) * IF( INFO.NE.0 ) THEN WRITE( *,* ) '>>>Warning: INFO returned by ', $ 'SGEQPX is:', INFO INFO = 0 END IF * TIME = S2 - S1 IC = IC + 1 IF( TIME.LT.TIMMIN ) THEN CALL SLACPY( 'All', M, N, COPYA, LDA, $ A, LDA ) GO TO 110 END IF * * Subtract the time used in SLACPY. * ICL = 1 S1 = SECOND( ) 100 CONTINUE S2 = SECOND( ) UNTIME = S2 - S1 ICL = ICL + 1 IF( ICL.LE.IC ) THEN CALL SLACPY( 'All', M, N, COPYA, LDA, $ A, LDA ) GO TO 100 END IF * * The number of flops of xGEQPX is approximately the * the number of flops of xGEQPF plus the number of * flops required by xORMQR to update matrix C. * TIME = ( TIME-UNTIME ) / REAL( IC ) * OPS = SOPLA( 'SGEQPF', M, N, 0, 0, NB ) $ + SOPLA( 'SORMQR', M, K, MINMN, 0, NB ) RESLTS( INB, IM, ILDA ) = $ SMFLOP( OPS, TIME, INFO ) * 50 CONTINUE 40 CONTINUE 30 CONTINUE * * Print the results for each value of K and type of matrix. * WRITE( NOUT, FMT = 9995 )SUBNAM( 1 ) WRITE( NOUT, FMT = 9996 )K, IMODE DO 120 I = 1, NLDA WRITE( NOUT, FMT = 9997 )I,LDAVAL( I ) 120 CONTINUE WRITE( NOUT, FMT = * ) CALL SPRTB4( '( NB, NX)', 'M', 'N', NNB, NBVAL, NXVAL, $ NM, MVAL, NVAL, NLDA, RESLTS( 1, 1, 1 ), $ LDR1, LDR2, NOUT ) * * * ***************** * * Timing xGEQPY * * ***************** * * Do for each value of LDA: * DO 200 ILDA = 1, NLDA LDA = LDAVAL( ILDA ) * * Do for each pair of values (M,N): * DO 210 IM = 1, NM M = MVAL( IM ) N = NVAL( IM ) MINMN = MIN( M, N ) * * Generate a test matrix of size m by n using the * singular value distribution indicated by MODE. * CALL SLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', $ B, MODE, COND, DMAX, M, N, $ 'No packing', COPYA, LDA, WORK, INFO ) * * Do for each pair of values (NB,NX) in NBVAL and NXVAL: * DO 220 INB = 1, NNB NB = NBVAL( INB ) CALL XLAENV( 1, NB ) NX = NXVAL( INB ) CALL XLAENV( 3, NX ) * IF( JOB.EQ.1 ) THEN IF( NB.LT.3 ) THEN LW = MAX( 1, 2*MINMN+3*N ) ELSE LW = MAX( 1, 2*MINMN+NB*N ) END IF ELSE IF( NB.LT.3 ) THEN LW = MAX( 1, 2*MINMN+2*N+MAX(K,N) ) ELSE LW = MAX( 1, 2*MINMN+NB*NB+NB*MAX(K,N) ) END IF END IF * * SGEQPY: Rank-Revealing QR factorization * CALL SLACPY( 'All', M, N, COPYA, LDA, A, LDA ) IC = 0 S1 = SECOND( ) 230 CONTINUE * CALL SGEQPY( JOB, M, N, K, A, LDA, B, LDA, $ IWORK, IRCOND, ORCOND, RANK, SVLUES, $ WORK, LW, INFO ) S2 = SECOND( ) * IF( INFO.NE.0 ) THEN WRITE( *,* ) '>>>Warning: INFO returned by ', $ 'SGEQPY is:', INFO INFO = 0 END IF * TIME = S2 - S1 IC = IC + 1 IF( TIME.LT.TIMMIN ) THEN CALL SLACPY( 'All', M, N, COPYA, LDA, $ A, LDA ) GO TO 230 END IF * * Subtract the time used in SLACPY. * ICL = 1 S1 = SECOND( ) 240 CONTINUE S2 = SECOND( ) UNTIME = S2 - S1 ICL = ICL + 1 IF( ICL.LE.IC ) THEN CALL SLACPY( 'All', M, N, COPYA, LDA, $ A, LDA ) GO TO 240 END IF * * The number of flops of xGEQPY is approximately the * the number of flops of xGEQPF plus the number of * flops required by xORMQR to update matrix C. * TIME = ( TIME-UNTIME ) / REAL( IC ) * OPS = SOPLA( 'SGEQPF', M, N, 0, 0, NB ) $ + SOPLA( 'SORMQR', M, K, MINMN, 0, NB ) RESLTS( INB, IM, ILDA ) = $ SMFLOP( OPS, TIME, INFO ) * 220 CONTINUE 210 CONTINUE 200 CONTINUE * * Print the results for each value of K and type of matrix. * WRITE( NOUT, FMT = 9995 )SUBNAM( 2 ) WRITE( NOUT, FMT = 9996 )K, IMODE DO 250 I = 1, NLDA WRITE( NOUT, FMT = 9997 )I,LDAVAL( I ) 250 CONTINUE WRITE( NOUT, FMT = * ) CALL SPRTB4( '( NB, NX)', 'M', 'N', NNB, NBVAL, NXVAL, $ NM, MVAL, NVAL, NLDA, RESLTS( 1, 1, 1 ), $ LDR1, LDR2, NOUT ) * 20 CONTINUE 10 CONTINUE * 9995 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' ) 9996 FORMAT( 5X, 'with K = ', I4, ' and type of matrix:', I4 ) 9997 FORMAT( 5X, 'line ', I4, ' with LDA = ', I4 ) 9999 FORMAT( 1X, A6, ' timing run not attempted', / ) 1000 CONTINUE RETURN * * End of STIMRR * END SHAR_EOF fi # end of overwriting check if test -f 'xlaenv.f' then echo shar: will not over-write existing file "'xlaenv.f'" else cat << SHAR_EOF > 'xlaenv.f' SUBROUTINE XLAENV( ISPEC, NVALUE ) * * -- 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 * * .. Scalar Arguments .. INTEGER ISPEC, NVALUE * .. * * Purpose * ======= * * XLAENV sets certain machine- and problem-dependent quantities * which will later be retrieved by ILAENV. * * Arguments * ========= * * ISPEC (input) INTEGER * Specifies the parameter to be set in the COMMON array IPARMS. * = 1: the optimal blocksize; if this value is 1, an unblocked * algorithm will give the best performance. * = 2: the minimum block size for which the block routine * should be used; if the usable block size is less than * this value, an unblocked routine should be used. * = 3: the crossover point (in a block routine, for N less * than this value, an unblocked routine should be used) * = 4: the number of shifts, used in the nonsymmetric * eigenvalue routines * = 5: the minimum column dimension for blocking to be used; * rectangular blocks must have dimension at least k by m, * where k is given by ILAENV(2,...) and m by ILAENV(5,...) * = 6: the crossover point for the SVD (when reducing an m by n * matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds * this value, a QR factorization is used first to reduce * the matrix to a triangular form) * = 7: the number of processors * = 8: another crossover point, for the multishift QR and QZ * methods for nonsymmetric eigenvalue problems. * * NVALUE (input) INTEGER * The value of the parameter specified by ISPEC. * * ===================================================================== * * .. Arrays in Common .. INTEGER IPARMS( 100 ) * .. * .. Common blocks .. COMMON / CLAENV / IPARMS * .. * .. Save statement .. SAVE / CLAENV / * .. * .. Executable Statements .. * IF( ISPEC.GE.1 .AND. ISPEC.LE.8 ) THEN IPARMS( ISPEC ) = NVALUE END IF * RETURN * * End of XLAENV * END SHAR_EOF fi # end of overwriting check if test -f 'ztimaa.f' then echo shar: will not over-write existing file "'ztimaa.f'" else cat << SHAR_EOF > 'ztimaa.f' PROGRAM ZTIMAA * * -- LAPACK timing routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * Rewritten to include the timing of rrqr code. * * Purpose * ======= * * An annotated example of a data file can be obtained by deleting the * first 3 characters from the following lines: * LAPACK timing, COMPLEX*16 square matrices * 5 Number of values of M * 100 200 300 400 500 Values of M (row dimension) * 5 Number of values of N * 100 200 300 400 500 Values of N (column dimension) * 2 Number of values of K * 100 400 Values of K * 5 Number of values of NB * 1 16 32 48 64 Values of NB (blocksize) * 0 48 128 128 128 Values of NX (crossover point) * 2 Number of values of LDA * 512 513 Values of LDA (leading dimension) * 0.0 Minimum time in seconds * ZQR T T F * ZQP T * ZRR T * * The routines are timed for all combinations of applicable values of * M, N, K, NB, NX, and LDA, and for all combinations of options such as * UPLO and TRANS. For Level 2 BLAS timings, values of NB are used for * INCX. Certain subroutines, such as the QR factorization, treat the * values of M and N as ordered pairs and operate on M x N matrices. * * Internal Parameters * =================== * * NMAX INTEGER * The maximum value of M or N for square matrices. * * LDAMAX INTEGER * The maximum value of LDA. * * NMAXB INTEGER * The maximum value of N for band matrices. * * MAXVAL INTEGER * The maximum number of values that can be read in for M, N, * K, NB, or NX. * * MXNLDA INTEGER * The maximum number of values that can be read in for LDA. * * NIN INTEGER * The unit number for input. Currently set to 5 (std input). * * NOUT INTEGER * The unit number for output. Currently set to 6 (std output). * * ===================================================================== * * .. Parameters .. INTEGER NMAX, LDAMAX, NMAXB PARAMETER ( NMAX = 1001, LDAMAX = NMAX+4, NMAXB = 5000 ) INTEGER LA PARAMETER ( LA = NMAX*LDAMAX ) INTEGER MAXVAL, MXNLDA PARAMETER ( MAXVAL = 12, MXNLDA = 4 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) * .. * .. Local Scalars .. LOGICAL BLAS, LDAMOK, LDANOK, LDAOK, MOK, NOK, NXNBOK CHARACTER C1 CHARACTER*2 C2 CHARACTER*3 C3 CHARACTER*80 LINE INTEGER I, L, LDR1, LDR2, LDR3, MAXK, MAXLDA, $ MAXM, MAXN, MAXNB, MKMAX, NEED, NK, NLDA, NM, $ NN, NNB DOUBLE PRECISION S1, S2, TIMMIN * .. * .. Local Arrays .. INTEGER IWORK( 2*NMAXB ), KVAL( MAXVAL ), $ LDAVAL( MXNLDA ), MVAL( MAXVAL ), $ NBVAL( MAXVAL ), NVAL( MAXVAL ), $ NXVAL( MAXVAL ) DOUBLE PRECISION D( 2*NMAX ), $ RESLTS( MAXVAL, MAXVAL, 2*MXNLDA, 4*MAXVAL ) COMPLEX*16 A( LA, 4 ), E( 2*NMAX ) * .. * .. External Functions .. LOGICAL LSAME, LSAMEN DOUBLE PRECISION DSECND EXTERNAL LSAME, LSAMEN, DSECND * .. * .. External Subroutines .. EXTERNAL ZTIMMM, ZTIMMV, $ ZTIMQP, ZTIMQR, ZTIMRR * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Arrays in Common .. INTEGER IPARMS( 100 ) * .. * .. Common blocks .. COMMON / CLAENV / IPARMS * .. * .. Executable Statements .. * S1 = DSECND( ) LDR1 = MAXVAL LDR2 = MAXVAL LDR3 = 2*MXNLDA * * Read the first line. The first four characters must be 'BLAS' * for the BLAS data file format to be used. Otherwise, the LAPACK * data file format is assumed. * READ( NIN, FMT = '( A80 )' )LINE BLAS = LSAMEN( 4, LINE, 'BLAS' ) * * Find the last non-blank and print the first line of input as the * first line of output. * DO 10 L = 80, 1, -1 IF( LINE( L: L ).NE.' ' ) $ GO TO 20 10 CONTINUE L = 1 20 CONTINUE WRITE( NOUT, FMT = '( 1X, A, / )' )LINE( 1: L ) * * Read in NM and the values for M. * READ( NIN, FMT = * )NM IF( NM.GT.MAXVAL ) THEN WRITE( NOUT, FMT = 9999 )'M', 'NM', MAXVAL NM = MAXVAL END IF READ( NIN, FMT = * )( MVAL( I ), I = 1, NM ) WRITE( NOUT, FMT = 9991 )'M: ', ( MVAL( I ), I = 1, NM ) * * Check that M <= NMAXB for all values of M. * MOK = .TRUE. MAXM = 0 DO 30 I = 1, NM MAXM = MAX( MVAL( I ), MAXM ) IF( MVAL( I ).GT.NMAXB ) THEN WRITE( NOUT, FMT = 9997 )'M', MVAL( I ), NMAXB MOK = .FALSE. END IF 30 CONTINUE IF( .NOT.MOK ) $ WRITE( NOUT, FMT = * ) * * Read in NN and the values for N. * READ( NIN, FMT = * )NN IF( NN.GT.MAXVAL ) THEN WRITE( NOUT, FMT = 9999 )'N', 'NN', MAXVAL NN = MAXVAL END IF READ( NIN, FMT = * )( NVAL( I ), I = 1, NN ) WRITE( NOUT, FMT = 9991 )'N: ', ( NVAL( I ), I = 1, NN ) * * Check that N <= NMAXB for all values of N. * NOK = .TRUE. MAXN = 0 DO 40 I = 1, NN MAXN = MAX( NVAL( I ), MAXN ) IF( NVAL( I ).GT.NMAXB ) THEN WRITE( NOUT, FMT = 9997 )'N', NVAL( I ), NMAXB NOK = .FALSE. END IF 40 CONTINUE IF( .NOT.NOK ) $ WRITE( NOUT, FMT = * ) * * Read in NK and the values for K. * READ( NIN, FMT = * )NK IF( NK.GT.MAXVAL ) THEN WRITE( NOUT, FMT = 9999 )'K', 'NK', MAXVAL NK = MAXVAL END IF READ( NIN, FMT = * )( KVAL( I ), I = 1, NK ) WRITE( NOUT, FMT = 9991 )'K: ', ( KVAL( I ), I = 1, NK ) * * Find the maximum value of K (= NRHS). * MAXK = 0 DO 50 I = 1, NK MAXK = MAX( KVAL( I ), MAXK ) 50 CONTINUE MKMAX = MAXM*MAX( 2, MAXK ) * * Read in NNB and the values for NB. For the BLAS input files, * NBVAL is used to store values for INCX and INCY. * READ( NIN, FMT = * )NNB IF( NNB.GT.MAXVAL ) THEN WRITE( NOUT, FMT = 9999 )'NB', 'NNB', MAXVAL NNB = MAXVAL END IF READ( NIN, FMT = * )( NBVAL( I ), I = 1, NNB ) * * Find the maximum value of NB. * MAXNB = 0 DO 60 I = 1, NNB MAXNB = MAX( NBVAL( I ), MAXNB ) 60 CONTINUE * IF( BLAS ) THEN WRITE( NOUT, FMT = 9991 )'INCX: ', ( NBVAL( I ), I = 1, NNB ) DO 70 I = 1, NNB NXVAL( I ) = 0 70 CONTINUE ELSE * * LAPACK data files: Read in the values for NX. * READ( NIN, FMT = * )( NXVAL( I ), I = 1, NNB ) * WRITE( NOUT, FMT = 9991 )'NB: ', ( NBVAL( I ), I = 1, NNB ) WRITE( NOUT, FMT = 9991 )'NX: ', ( NXVAL( I ), I = 1, NNB ) END IF * * Read in NLDA and the values for LDA. * READ( NIN, FMT = * )NLDA IF( NLDA.GT.MXNLDA ) THEN WRITE( NOUT, FMT = 9999 )'LDA', 'NLDA', MXNLDA NLDA = MXNLDA END IF READ( NIN, FMT = * )( LDAVAL( I ), I = 1, NLDA ) WRITE( NOUT, FMT = 9991 )'LDA: ', ( LDAVAL( I ), I = 1, NLDA ) * * Check that LDA >= 1 for all values of LDA. * LDAOK = .TRUE. MAXLDA = 0 DO 80 I = 1, NLDA MAXLDA = MAX( LDAVAL( I ), MAXLDA ) IF( LDAVAL( I ).LE.0 ) THEN WRITE( NOUT, FMT = 9998 )LDAVAL( I ) LDAOK = .FALSE. END IF 80 CONTINUE IF( .NOT.LDAOK ) $ WRITE( NOUT, FMT = * ) * * Check that MAXLDA*MAXN <= LA (for the dense routines). * LDANOK = .TRUE. NEED = MAXLDA*MAXN IF( NEED.GT.LA ) THEN WRITE( NOUT, FMT = 9995 )MAXLDA, MAXN, NEED LDANOK = .FALSE. END IF * * Check that MAXLDA*MAXM + MAXM*MAXK <= 3*LA (for band routines). * LDAMOK = .TRUE. NEED = MAXLDA*MAXM + MAXM*MAXK IF( NEED.GT.3*LA ) THEN NEED = ( NEED+2 ) / 3 WRITE( NOUT, FMT = 9994 )MAXLDA, MAXM, MAXK, NEED LDAMOK = .FALSE. END IF * * Check that MAXN*MAXNB (or MAXN*INCX) <= LA. * NXNBOK = .TRUE. NEED = MAXN*MAXNB IF( NEED.GT.LA ) THEN WRITE( NOUT, FMT = 9996 )MAXN, MAXNB, NEED NXNBOK = .FALSE. END IF * IF( .NOT.( MOK .AND. NOK .AND. LDAOK .AND. LDANOK .AND. NXNBOK ) ) $ THEN WRITE( NOUT, FMT = 9984 ) GO TO 110 END IF IF( .NOT.LDAMOK ) $ WRITE( NOUT, FMT = * ) * * Read the minimum time to time a subroutine. * WRITE( NOUT, FMT = * ) READ( NIN, FMT = * )TIMMIN WRITE( NOUT, FMT = 9993 )TIMMIN WRITE( NOUT, FMT = * ) * * Read the first input line. * READ( NIN, FMT = '(A)', END = 100 )LINE * * If the first record is the special signal 'NONE', then get the * next line but don't time ZGEMV and ZGEMM. * IF( LSAMEN( 4, LINE, 'NONE' ) ) THEN READ( NIN, FMT = '(A)', END = 100 )LINE ELSE WRITE( NOUT, FMT = 9990 ) * * Time ZGEMV and ZGEMM. * CALL ZTIMMV( 'ZGEMV ', NN, NVAL, NNB, NBVAL, NLDA, $ LDAVAL, TIMMIN, A( 1, 1 ), LA, A( 1, 2 ), $ A( 1, 3 ), RESLTS, LDR1, LDR2, NOUT ) CALL ZTIMMM( 'ZGEMM ', 'N', NN, NVAL, NLDA, LDAVAL, $ TIMMIN, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), RESLTS, $ LDR1, LDR2, NOUT ) END IF * * Call the appropriate timing routine for each input line. * WRITE( NOUT, FMT = 9988 ) 90 CONTINUE C1 = LINE( 1: 1 ) C2 = LINE( 2: 3 ) C3 = LINE( 4: 6 ) * * Check first character for correct precision. * IF( .NOT.LSAME( C1, 'Zprecision' ) ) THEN WRITE( NOUT, FMT = 9987 )LINE( 1: 6 ) * ELSE IF( LSAMEN( 2, C2, 'QR' ) .OR. LSAMEN( 2, C3, 'QR' ) .OR. $ LSAMEN( 2, C3( 2: 3 ), 'QR' ) ) THEN * * QR routines * CALL ZTIMQR( LINE, NN, MVAL, NVAL, NK, KVAL, NNB, NBVAL, $ NXVAL, NLDA, LDAVAL, TIMMIN, A( 1, 1 ), E, $ A( 1, 2 ), A( 1, 3 ), D, RESLTS, LDR1, LDR2, $ LDR3, NOUT ) * ELSE IF( LSAMEN( 2, C2, 'QP' ) .OR. LSAMEN( 3, C3, 'QPF' ) ) THEN * * QR with column pivoting * CALL ZTIMQP( LINE, NM, MVAL, NVAL, NLDA, LDAVAL, TIMMIN, $ A( 1, 1 ), A( 1, 2 ), E, A( 1, 3 ), D, IWORK, $ RESLTS, LDR1, LDR2, NOUT ) * ELSE IF( LSAMEN( 2, C2, 'RR' ) .OR. LSAMEN( 3, C3, 'RRF' ) ) THEN * * Rank-Revealing QR factorization * CALL ZTIMRR( LINE, NM, MVAL, NVAL, NK, KVAL, $ NNB, NBVAL, NXVAL, NLDA, LDAVAL, TIMMIN, $ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), $ A( 1, 4 ), D, IWORK, $ RESLTS, LDR1, LDR2, NOUT ) * ELSE * WRITE( NOUT, FMT = 9987 )LINE( 1: 6 ) END IF * * Read the next line of the input file. * READ( NIN, FMT = '(A)', END = 100 )LINE GO TO 90 * * Branch to this line when the last record is read. * 100 CONTINUE S2 = DSECND( ) WRITE( NOUT, FMT = 9986 ) WRITE( NOUT, FMT = 9985 )S2 - S1 110 CONTINUE * 9999 FORMAT( ' Too many values of ', A, ' using ', A, ' = ', I2 ) 9998 FORMAT( ' *** LDA = ', I7, ' is too small, must have ', $ 'LDA > 0.' ) 9997 FORMAT( ' *** ', A1, ' = ', I7, ' is too big: ', $ 'maximum allowed is', I7 ) 9996 FORMAT( ' *** N*NB is too big for N =', I6, ', NB =', I6, $ / ' --> Increase LA to at least ', I8 ) 9995 FORMAT( ' *** LDA*N is too big for the dense routines ', '(LDA =', $ I6, ', N =', I6, ')', / ' --> Increase LA to at least ', $ I8 ) 9994 FORMAT( ' *** (LDA+K)*M is too big for the band routines ', $ '(LDA=', I6, ', M=', I6, ', K=', I6, ')', $ / ' --> Increase LA to at least ', I8 ) 9993 FORMAT( ' The minimum time a subroutine will be timed = ', F6.3, $ ' seconds' ) 9991 FORMAT( 4X, A7, 1X, 10I6, / 12X, 10I6 ) 9990 FORMAT( / ' ------------------------------', $ / ' >>>>> Sample BLAS <<<<<', $ / ' ------------------------------' ) 9988 FORMAT( / ' ------------------------------', $ / ' >>>>> Timing data <<<<<', $ / ' ------------------------------' ) 9987 FORMAT( 1X, A6, ': Unrecognized path or subroutine name', / ) 9986 FORMAT( ' End of tests' ) 9985 FORMAT( ' Total time used = ', F12.2, ' seconds' ) 9984 FORMAT( / ' Tests not done due to input errors' ) * * End of ZTIMAA * END SHAR_EOF fi # end of overwriting check if test -f 'ztimmg.f' then echo shar: will not over-write existing file "'ztimmg.f'" else cat << SHAR_EOF > 'ztimmg.f' SUBROUTINE ZTIMMG( IFLAG, M, N, A, LDA, KL, KU ) * * -- LAPACK timing 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 IFLAG, KL, KU, LDA, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ) * .. * * Purpose * ======= * * ZTIMMG generates a complex test matrix whose type is given by IFLAG. * All the matrices are Toeplitz (constant along a diagonal), with * random elements on each diagonal. * * Arguments * ========= * * IFLAG (input) INTEGER * The type of matrix to be generated. * = 0 or 1: General matrix * = 2 or -2: General banded matrix * = 3 or -3: Hermitian positive definite matrix * = 4 or -4: Hermitian positive definite packed * = 5 or -5: Hermitian positive definite banded * = 6 or -6: Hermitian indefinite matrix * = 7 or -7: Hermitian indefinite packed * = 8 or -8: Symmetric indefinite matrix * = 9 or -9: Symmetric indefinite packed * = 10 or -10: Symmetric indefinite banded * = 11 or -11: Triangular matrix * = 12 or -12: Triangular packed * = 13 or -13: Triangular banded * = 14: General tridiagonal * For Hermitian, symmetric, or triangular matrices, IFLAG > 0 * indicates upper triangular storage and IFLAG < 0 indicates * lower triangular storage. * * M (input) INTEGER * The number of rows of the matrix to be generated. * * N (input) INTEGER * The number of columns of the matrix to be generated. * * A (output) COMPLEX*16 array, dimension (LDA,N) * The generated matrix. * * If the absolute value of IFLAG is 1, 3, 6, or 8, the leading * M x N (or N x N) subblock is used to store the matrix. * If the matrix is symmetric, only the upper or lower triangle * of this block is referenced. * * If the absolute value of IFLAG is 4, 7, or 9, the matrix is * Hermitian or symmetric and packed storage is used for the * upper or lower triangle. The triangular matrix is stored * columnwise as a linear array, and the array A is treated as a * vector of length LDA. LDA must be set to at least N*(N+1)/2. * * If the absolute value of IFLAG is 2 or 5, the matrix is * returned in band format. The columns of the matrix are * specified in the columns of A and the diagonals of the * matrix are specified in the rows of A, with the leading * diagonal in row * KL + KU + 1, if IFLAG = 2 * KU + 1, if IFLAG = 5 or -2 * 1, if IFLAG = -5 * If IFLAG = 2, the first KL rows are not used to leave room * for pivoting in ZGBTRF. * * LDA (input) INTEGER * The leading dimension of A. If the generated matrix is * packed, LDA >= N*(N+1)/2, otherwise LDA >= max(1,M). * * KL (input) INTEGER * The number of subdiagonals if IFLAG = 2, 5, or -5. * * KU (input) INTEGER * The number of superdiagonals if IFLAG = 2, 5, or -5. * * ===================================================================== * * .. Local Scalars .. INTEGER I, J, JJ, JN, K, MJ, MU * .. * .. Local Arrays .. INTEGER ISEED( 4 ) * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MIN * .. * .. External Functions .. COMPLEX*16 ZLARND EXTERNAL ZLARND * .. * .. External Subroutines .. EXTERNAL ZCOPY, ZLARNV * .. * .. Data statements .. DATA ISEED / 0, 0, 0, 1 / * .. * .. Executable Statements .. * IF( M.LE.0 .OR. N.LE.0 ) THEN RETURN * ELSE IF( IFLAG.EQ.0 .OR. IFLAG.EQ.1 ) THEN * * General matrix * * Set first column and row to random values. * CALL ZLARNV( 2, ISEED, M, A( 1, 1 ) ) DO 10 J = 2, N, M MJ = MIN( M, N-J+1 ) CALL ZLARNV( 2, ISEED, MJ, A( 1, J ) ) IF( MJ.GT.1 ) $ CALL ZCOPY( MJ-1, A( 2, J ), 1, A( 1, J+1 ), LDA ) 10 CONTINUE * * Fill in the rest of the matrix. * DO 30 J = 2, N DO 20 I = 2, M A( I, J ) = A( I-1, J-1 ) 20 CONTINUE 30 CONTINUE * ELSE IF( IFLAG.EQ.2 .OR. IFLAG.EQ.-2 ) THEN * * General band matrix * IF( IFLAG.EQ.2 ) THEN K = KL + KU + 1 ELSE K = KU + 1 END IF CALL ZLARNV( 2, ISEED, MIN( M, KL+1 ), A( K, 1 ) ) MU = MIN( N-1, KU ) CALL ZLARNV( 2, ISEED, MU+1, A( K-MU, N ) ) DO 40 J = 2, N - 1 MU = MIN( J-1, KU ) CALL ZCOPY( MU, A( K-MU, N ), 1, A( K-MU, J ), 1 ) CALL ZCOPY( MIN( M-J+1, KL+1 ), A( K, 1 ), 1, A( K, J ), 1 ) 40 CONTINUE * ELSE IF( IFLAG.EQ.3 ) THEN * * Hermitian positive definite, upper triangle * CALL ZLARNV( 2, ISEED, N-1, A( 1, N ) ) A( N, N ) = DBLE( N ) DO 50 J = N - 1, 1, -1 CALL ZCOPY( J, A( N-J+1, N ), 1, A( 1, J ), 1 ) 50 CONTINUE * ELSE IF( IFLAG.EQ.-3 ) THEN * * Hermitian positive definite, lower triangle * A( 1, 1 ) = DBLE( N ) IF( N.GT.1 ) $ CALL ZLARNV( 2, ISEED, N-1, A( 2, 1 ) ) DO 60 J = 2, N CALL ZCOPY( N-J+1, A( 1, 1 ), 1, A( J, J ), 1 ) 60 CONTINUE * ELSE IF( IFLAG.EQ.4 ) THEN * * Hermitian positive definite packed, upper triangle * JN = ( N-1 )*N / 2 + 1 CALL ZLARNV( 2, ISEED, N-1, A( JN, 1 ) ) A( JN+N-1, 1 ) = DBLE( N ) JJ = JN DO 70 J = N - 1, 1, -1 JJ = JJ - J JN = JN + 1 CALL ZCOPY( J, A( JN, 1 ), 1, A( JJ, 1 ), 1 ) 70 CONTINUE * ELSE IF( IFLAG.EQ.-4 ) THEN * * Hermitian positive definite packed, lower triangle * A( 1, 1 ) = DBLE( N ) IF( N.GT.1 ) $ CALL ZLARNV( 2, ISEED, N-1, A( 2, 1 ) ) JJ = N + 1 DO 80 J = 2, N CALL ZCOPY( N-J+1, A( 1, 1 ), 1, A( JJ, 1 ), 1 ) JJ = JJ + N - J + 1 80 CONTINUE * ELSE IF( IFLAG.EQ.5 ) THEN * * Hermitian positive definite banded, upper triangle * K = KL MU = MIN( N-1, K ) CALL ZLARNV( 2, ISEED, MU, A( K+1-MU, N ) ) A( K+1, N ) = DBLE( N ) DO 90 J = N - 1, 1, -1 MU = MIN( J, K+1 ) CALL ZCOPY( MU, A( K+2-MU, N ), 1, A( K+2-MU, J ), 1 ) 90 CONTINUE * ELSE IF( IFLAG.EQ.-5 ) THEN * * Hermitian positive definite banded, lower triangle * K = KL A( 1, 1 ) = DBLE( N ) CALL ZLARNV( 2, ISEED, MIN( N-1, K ), A( 2, 1 ) ) DO 100 J = 2, N CALL ZCOPY( MIN( N-J+1, K+1 ), A( 1, 1 ), 1, A( 1, J ), 1 ) 100 CONTINUE * ELSE IF( IFLAG.EQ.6 ) THEN * * Hermitian indefinite, upper triangle * CALL ZLARNV( 2, ISEED, N, A( 1, N ) ) A( N, N ) = DBLE( A( N, N ) ) DO 110 J = N - 1, 1, -1 CALL ZCOPY( J, A( N-J+1, N ), 1, A( 1, J ), 1 ) 110 CONTINUE * ELSE IF( IFLAG.EQ.-6 ) THEN * * Hermitian indefinite, lower triangle * CALL ZLARNV( 2, ISEED, N, A( 1, 1 ) ) A( 1, 1 ) = DBLE( A( 1, 1 ) ) DO 120 J = 2, N CALL ZCOPY( N-J+1, A( 1, 1 ), 1, A( J, J ), 1 ) 120 CONTINUE * ELSE IF( IFLAG.EQ.7 ) THEN * * Hermitian indefinite packed, upper triangle * JN = ( N-1 )*N / 2 + 1 CALL ZLARNV( 2, ISEED, N, A( JN, 1 ) ) A( JN+N-1, 1 ) = DBLE( A( JN+N-1, 1 ) ) JJ = JN DO 130 J = N - 1, 1, -1 JJ = JJ - J JN = JN + 1 CALL ZCOPY( J, A( JN, 1 ), 1, A( JJ, 1 ), 1 ) 130 CONTINUE * ELSE IF( IFLAG.EQ.-7 ) THEN * * Hermitian indefinite packed, lower triangle * CALL ZLARNV( 2, ISEED, N, A( 1, 1 ) ) A( 1, 1 ) = DBLE( A( 1, 1 ) ) JJ = N + 1 DO 140 J = 2, N CALL ZCOPY( N-J+1, A( 1, 1 ), 1, A( JJ, 1 ), 1 ) JJ = JJ + N - J + 1 140 CONTINUE * ELSE IF( IFLAG.EQ.8 ) THEN * * Symmetric indefinite, upper triangle * CALL ZLARNV( 2, ISEED, N, A( 1, N ) ) DO 150 J = N - 1, 1, -1 CALL ZCOPY( J, A( N-J+1, N ), 1, A( 1, J ), 1 ) 150 CONTINUE * ELSE IF( IFLAG.EQ.-8 ) THEN * * Symmetric indefinite, lower triangle * CALL ZLARNV( 2, ISEED, N, A( 1, 1 ) ) DO 160 J = 2, N CALL ZCOPY( N-J+1, A( 1, 1 ), 1, A( J, J ), 1 ) 160 CONTINUE * ELSE IF( IFLAG.EQ.9 ) THEN * * Symmetric indefinite packed, upper triangle * JN = ( N-1 )*N / 2 + 1 CALL ZLARNV( 2, ISEED, N, A( JN, 1 ) ) JJ = JN DO 170 J = N - 1, 1, -1 JJ = JJ - J JN = JN + 1 CALL ZCOPY( J, A( JN, 1 ), 1, A( JJ, 1 ), 1 ) 170 CONTINUE * ELSE IF( IFLAG.EQ.-9 ) THEN * * Symmetric indefinite packed, lower triangle * CALL ZLARNV( 2, ISEED, N, A( 1, 1 ) ) JJ = N + 1 DO 180 J = 2, N CALL ZCOPY( N-J+1, A( 1, 1 ), 1, A( JJ, 1 ), 1 ) JJ = JJ + N - J + 1 180 CONTINUE * ELSE IF( IFLAG.EQ.10 ) THEN * * Symmetric indefinite banded, upper triangle * K = KL MU = MIN( N, K+1 ) CALL ZLARNV( 2, ISEED, MU, A( K+2-MU, N ) ) DO 190 J = N - 1, 1, -1 MU = MIN( J, K+1 ) CALL ZCOPY( MU, A( K+2-MU, N ), 1, A( K+2-MU, J ), 1 ) 190 CONTINUE * ELSE IF( IFLAG.EQ.-10 ) THEN * * Symmetric indefinite banded, lower triangle * K = KL CALL ZLARNV( 2, ISEED, MIN( N, K+1 ), A( 1, 1 ) ) DO 200 J = 2, N CALL ZCOPY( MIN( N-J+1, K+1 ), A( 1, 1 ), 1, A( 1, J ), 1 ) 200 CONTINUE * ELSE IF( IFLAG.EQ.11 ) THEN * * Upper triangular * CALL ZLARNV( 2, ISEED, N-1, A( 1, N ) ) A( N, N ) = DBLE( N )*ZLARND( 5, ISEED ) DO 210 J = N - 1, 1, -1 CALL ZCOPY( J, A( N-J+1, N ), 1, A( 1, J ), 1 ) 210 CONTINUE * ELSE IF( IFLAG.EQ.-11 ) THEN * * Lower triangular * A( 1, 1 ) = DBLE( N )*ZLARND( 5, ISEED ) IF( N.GT.1 ) $ CALL ZLARNV( 2, ISEED, N-1, A( 2, 1 ) ) DO 220 J = 2, N CALL ZCOPY( N-J+1, A( 1, 1 ), 1, A( J, J ), 1 ) 220 CONTINUE * ELSE IF( IFLAG.EQ.12 ) THEN * * Upper triangular packed * JN = ( N-1 )*N / 2 + 1 CALL ZLARNV( 2, ISEED, N-1, A( JN, 1 ) ) A( JN+N-1, 1 ) = DBLE( N )*ZLARND( 5, ISEED ) JJ = JN DO 230 J = N - 1, 1, -1 JJ = JJ - J JN = JN + 1 CALL ZCOPY( J, A( JN, 1 ), 1, A( JJ, 1 ), 1 ) 230 CONTINUE * ELSE IF( IFLAG.EQ.-12 ) THEN * * Lower triangular packed * A( 1, 1 ) = DBLE( N )*ZLARND( 5, ISEED ) IF( N.GT.1 ) $ CALL ZLARNV( 2, ISEED, N-1, A( 2, 1 ) ) JJ = N + 1 DO 240 J = 2, N CALL ZCOPY( N-J+1, A( 1, 1 ), 1, A( JJ, 1 ), 1 ) JJ = JJ + N - J + 1 240 CONTINUE * ELSE IF( IFLAG.EQ.13 ) THEN * * Upper triangular banded * K = KL MU = MIN( N-1, K ) CALL ZLARNV( 2, ISEED, MU, A( K+1-MU, N ) ) A( K+1, N ) = DBLE( K+1 )*ZLARND( 5, ISEED ) DO 250 J = N - 1, 1, -1 MU = MIN( J, K+1 ) CALL ZCOPY( MU, A( K+2-MU, N ), 1, A( K+2-MU, J ), 1 ) 250 CONTINUE * ELSE IF( IFLAG.EQ.-13 ) THEN * * Lower triangular banded * K = KL A( 1, 1 ) = DBLE( K+1 )*ZLARND( 5, ISEED ) IF( N.GT.1 ) $ CALL ZLARNV( 2, ISEED, MIN( N-1, K ), A( 2, 1 ) ) DO 260 J = 2, N CALL ZCOPY( MIN( N-J+1, K+1 ), A( 1, 1 ), 1, A( 1, J ), 1 ) 260 CONTINUE * ELSE IF( IFLAG.EQ.14 ) THEN * * General tridiagonal * CALL ZLARNV( 2, ISEED, 3*N-2, A ) END IF * RETURN * * End of ZTIMMG * END SHAR_EOF fi # end of overwriting check if test -f 'ztimmm.f' then echo shar: will not over-write existing file "'ztimmm.f'" else cat << SHAR_EOF > 'ztimmm.f' SUBROUTINE ZTIMMM( VNAME, LAB2, NN, NVAL, NLDA, LDAVAL, TIMMIN, A, $ B, C, RESLTS, LDR1, LDR2, NOUT ) * * -- LAPACK timing 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*( * ) LAB2, VNAME INTEGER LDR1, LDR2, NLDA, NN, NOUT DOUBLE PRECISION TIMMIN * .. * .. Array Arguments .. INTEGER LDAVAL( * ), NVAL( * ) DOUBLE PRECISION RESLTS( LDR1, LDR2, * ) COMPLEX*16 A( * ), B( * ), C( * ) * .. * * Purpose * ======= * * ZTIMMM times ZGEMM. * * Arguments * ========= * * VNAME (input) CHARACTER*(*) * The name of the Level 3 BLAS routine to be timed. * * LAB2 (input) CHARACTER*(*) * The name of the variable given in NVAL. * * NN (input) INTEGER * The number of values of N contained in the vector NVAL. * * NVAL (input) INTEGER array, dimension (NN) * The values of the matrix dimension N. * * NLDA (input) INTEGER * The number of values of LDA contained in the vector LDAVAL. * * LDAVAL (input) INTEGER array, dimension (NLDA) * The values of the leading dimension of the array A. * * TIMMIN (input) DOUBLE PRECISION * The minimum time a subroutine will be timed. * * A (workspace) COMPLEX*16 array, dimension (LDAMAX*NMAX) * where LDAMAX and NMAX are the maximum values permitted * for LDA and N. * * B (workspace) COMPLEX*16 array, dimension (LDAMAX*NMAX) * * C (workspace) COMPLEX*16 array, dimension (LDAMAX*NMAX) * * RESLTS (output) DOUBLE PRECISION array, dimension (LDR1,LDR2,NLDA) * The timing results for each subroutine over the relevant * values of N and LDA. * * LDR1 (input) INTEGER * The first dimension of RESLTS. LDR1 >= 1. * * LDR2 (input) INTEGER * The second dimension of RESLTS. LDR2 >= max(1,NN). * * NOUT (input) INTEGER * The unit number for output. * * ===================================================================== * * .. Parameters .. INTEGER NSUBS COMPLEX*16 ONE PARAMETER ( NSUBS = 1, ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. CHARACTER*6 CNAME INTEGER I, IC, ICL, ILDA, IN, INFO, ISUB, LDA, N DOUBLE PRECISION OPS, S1, S2, TIME, UNTIME * .. * .. Local Arrays .. LOGICAL TIMSUB( NSUBS ) CHARACTER*6 SUBNAM( NSUBS ) INTEGER IDUMMY( 1 ) * .. * .. External Functions .. LOGICAL LSAMEN DOUBLE PRECISION DMFLOP, DOPBL3, DSECND EXTERNAL LSAMEN, DMFLOP, DOPBL3, DSECND * .. * .. External Subroutines .. EXTERNAL ATIMCK, DPRTBL, ZGEMM, ZTIMMG * .. * .. Intrinsic Functions .. INTRINSIC DBLE * .. * .. Data statements .. DATA SUBNAM / 'ZGEMM ' / * .. * .. Executable Statements .. * CNAME = VNAME DO 10 ISUB = 1, NSUBS TIMSUB( ISUB ) = LSAMEN( 6, CNAME, SUBNAM( ISUB ) ) IF( TIMSUB( ISUB ) ) $ GO TO 20 10 CONTINUE WRITE( NOUT, FMT = 9999 )CNAME GO TO 80 20 CONTINUE * * Check that N <= LDA for the input values. * CALL ATIMCK( 2, CNAME, NN, NVAL, NLDA, LDAVAL, NOUT, INFO ) IF( INFO.GT.0 ) THEN WRITE( NOUT, FMT = 9998 )CNAME GO TO 80 END IF * DO 60 ILDA = 1, NLDA LDA = LDAVAL( ILDA ) DO 50 IN = 1, NN N = NVAL( IN ) * * Time ZGEMM * CALL ZTIMMG( 1, N, N, A, LDA, 0, 0 ) CALL ZTIMMG( 0, N, N, B, LDA, 0, 0 ) CALL ZTIMMG( 1, N, N, C, LDA, 0, 0 ) IC = 0 S1 = DSECND( ) 30 CONTINUE CALL ZGEMM( 'No transpose', 'No transpose', N, N, N, ONE, A, $ LDA, B, LDA, ONE, C, LDA ) S2 = DSECND( ) TIME = S2 - S1 IC = IC + 1 IF( TIME.LT.TIMMIN ) THEN CALL ZTIMMG( 1, N, N, C, LDA, 0, 0 ) GO TO 30 END IF * * Subtract the time used in ZTIMMG. * ICL = 1 S1 = DSECND( ) 40 CONTINUE S2 = DSECND( ) UNTIME = S2 - S1 ICL = ICL + 1 IF( ICL.LE.IC ) THEN CALL ZTIMMG( 1, N, N, C, LDA, 0, 0 ) GO TO 40 END IF * TIME = ( TIME-UNTIME ) / DBLE( IC ) OPS = DOPBL3( 'ZGEMM ', N, N, N ) RESLTS( 1, IN, ILDA ) = DMFLOP( OPS, TIME, 0 ) 50 CONTINUE 60 CONTINUE * * Print the table of results on unit NOUT. * WRITE( NOUT, FMT = 9997 )VNAME IF( NLDA.EQ.1 ) THEN WRITE( NOUT, FMT = 9996 )LDAVAL( 1 ) ELSE DO 70 I = 1, NLDA WRITE( NOUT, FMT = 9995 )I, LDAVAL( I ) 70 CONTINUE END IF WRITE( NOUT, FMT = * ) CALL DPRTBL( ' ', LAB2, 1, IDUMMY, NN, NVAL, NLDA, RESLTS, LDR1, $ LDR2, NOUT ) * 80 CONTINUE RETURN 9999 FORMAT( 1X, A6, ': Unrecognized path or subroutine name', / ) 9998 FORMAT( 1X, A6, ' timing run not attempted', / ) 9997 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' ) 9996 FORMAT( 5X, 'with LDA = ', I5 ) 9995 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 ) * * End of ZTIMMM * END SHAR_EOF fi # end of overwriting check if test -f 'ztimmv.f' then echo shar: will not over-write existing file "'ztimmv.f'" else cat << SHAR_EOF > 'ztimmv.f' SUBROUTINE ZTIMMV( VNAME, NN, NVAL, NK, KVAL, NLDA, LDAVAL, $ TIMMIN, A, LB, B, C, RESLTS, LDR1, LDR2, NOUT ) * * -- LAPACK timing 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*( * ) VNAME INTEGER LB, LDR1, LDR2, NK, NLDA, NN, NOUT DOUBLE PRECISION TIMMIN * .. * .. Array Arguments .. INTEGER KVAL( * ), LDAVAL( * ), NVAL( * ) DOUBLE PRECISION RESLTS( LDR1, LDR2, * ) COMPLEX*16 A( * ), B( * ), C( * ) * .. * * Purpose * ======= * * ZTIMMV times individual BLAS 2 routines. * * Arguments * ========= * * VNAME (input) CHARACTER*(*) * The name of the Level 2 BLAS routine to be timed. * * NN (input) INTEGER * The number of values of N contained in the vector NVAL. * * NVAL (input) INTEGER array, dimension (NN) * The values of the matrix dimension N. * * NK (input) INTEGER * The number of values of K contained in the vector KVAL. * * KVAL (input) INTEGER array, dimension (NK) * The values of the bandwidth K. * * NLDA (input) INTEGER * The number of values of LDA contained in the vector LDAVAL. * * LDAVAL (input) INTEGER array, dimension (NLDA) * The values of the leading dimension of the array A. * * TIMMIN (input) DOUBLE PRECISION * The minimum time a subroutine will be timed. * * A (workspace) COMPLEX*16 array, dimension (LDAMAX*NMAX) * where LDAMAX and NMAX are the maximum values permitted * for LDA and N. * * LB (input) INTEGER * The length of B and C, needed when timing ZGBMV. If timing * ZGEMV, LB >= LDAMAX*NMAX. * * B (workspace) COMPLEX*16 array, dimension (LB) * * C (workspace) COMPLEX*16 array, dimension (LB) * * RESLTS (output) DOUBLE PRECISION array, dimension (LDR1,LDR2,NLDA) * The timing results for each subroutine over the relevant * values of N and LDA. * * LDR1 (input) INTEGER * The first dimension of RESLTS. LDR1 >= max(1,NK). * * LDR2 (input) INTEGER * The second dimension of RESLTS. LDR2 >= max(1,NN). * * NOUT (input) INTEGER * The unit number for output. * * ===================================================================== * * .. Parameters .. INTEGER NSUBS COMPLEX*16 ONE PARAMETER ( NSUBS = 2, ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. CHARACTER LAB1, LAB2 CHARACTER*6 CNAME INTEGER I, IB, IC, ICL, IK, ILDA, IN, INFO, ISUB, K, $ KL, KU, LDA, LDB, N, NRHS DOUBLE PRECISION OPS, S1, S2, TIME, UNTIME * .. * .. Local Arrays .. LOGICAL TIMSUB( NSUBS ) CHARACTER*6 SUBNAM( NSUBS ) * .. * .. External Functions .. LOGICAL LSAME, LSAMEN DOUBLE PRECISION DMFLOP, DOPBL2, DSECND EXTERNAL LSAME, LSAMEN, DMFLOP, DOPBL2, DSECND * .. * .. External Subroutines .. EXTERNAL ATIMCK, DPRTBL, ZGBMV, ZGEMV, ZTIMMG * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN * .. * .. Data statements .. DATA SUBNAM / 'ZGEMV ', 'ZGBMV ' / * .. * .. Executable Statements .. * CNAME = VNAME DO 10 ISUB = 1, NSUBS TIMSUB( ISUB ) = LSAMEN( 6, CNAME, SUBNAM( ISUB ) ) IF( TIMSUB( ISUB ) ) $ GO TO 20 10 CONTINUE WRITE( NOUT, FMT = 9999 )CNAME GO TO 150 20 CONTINUE * * Check that N or K <= LDA for the input values. * IF( LSAME( CNAME( 3: 3 ), 'B' ) ) THEN CALL ATIMCK( 0, CNAME, NK, KVAL, NLDA, LDAVAL, NOUT, INFO ) LAB1 = 'M' LAB2 = 'K' ELSE CALL ATIMCK( 2, CNAME, NN, NVAL, NLDA, LDAVAL, NOUT, INFO ) LAB1 = ' ' LAB2 = 'N' END IF IF( INFO.GT.0 ) THEN WRITE( NOUT, FMT = 9998 )CNAME GO TO 150 END IF * * Print the table header on unit NOUT. * WRITE( NOUT, FMT = 9997 )VNAME IF( NLDA.EQ.1 ) THEN WRITE( NOUT, FMT = 9996 )LDAVAL( 1 ) ELSE DO 30 I = 1, NLDA WRITE( NOUT, FMT = 9995 )I, LDAVAL( I ) 30 CONTINUE END IF WRITE( NOUT, FMT = * ) * * Time ZGEMV * IF( TIMSUB( 1 ) ) THEN DO 80 ILDA = 1, NLDA LDA = LDAVAL( ILDA ) DO 70 IN = 1, NN N = NVAL( IN ) NRHS = N LDB = LDA CALL ZTIMMG( 1, N, N, A, LDA, 0, 0 ) CALL ZTIMMG( 0, N, NRHS, B, LDB, 0, 0 ) CALL ZTIMMG( 1, N, NRHS, C, LDB, 0, 0 ) IC = 0 S1 = DSECND( ) 40 CONTINUE IB = 1 DO 50 I = 1, NRHS CALL ZGEMV( 'No transpose', N, N, ONE, A, LDA, $ B( IB ), 1, ONE, C( IB ), 1 ) IB = IB + LDB 50 CONTINUE S2 = DSECND( ) TIME = S2 - S1 IC = IC + 1 IF( TIME.LT.TIMMIN ) THEN CALL ZTIMMG( 1, N, NRHS, C, LDB, 0, 0 ) GO TO 40 END IF * * Subtract the time used in ZTIMMG. * ICL = 1 S1 = DSECND( ) 60 CONTINUE S2 = DSECND( ) UNTIME = S2 - S1 ICL = ICL + 1 IF( ICL.LE.IC ) THEN CALL ZTIMMG( 1, N, NRHS, C, LDB, 0, 0 ) GO TO 60 END IF * TIME = ( TIME-UNTIME ) / DBLE( IC ) OPS = NRHS*DOPBL2( 'ZGEMV ', N, N, 0, 0 ) RESLTS( 1, IN, ILDA ) = DMFLOP( OPS, TIME, 0 ) 70 CONTINUE 80 CONTINUE * CALL DPRTBL( LAB1, LAB2, 1, NVAL, NN, NVAL, NLDA, RESLTS, LDR1, $ LDR2, NOUT ) * ELSE IF( TIMSUB( 2 ) ) THEN * * Time ZGBMV * DO 140 ILDA = 1, NLDA LDA = LDAVAL( ILDA ) DO 130 IN = 1, NN N = NVAL( IN ) DO 120 IK = 1, NK K = MIN( N-1, MAX( 0, KVAL( IK ) ) ) KL = K KU = K LDB = N CALL ZTIMMG( 2, N, N, A, LDA, KL, KU ) NRHS = MIN( K, LB / LDB ) CALL ZTIMMG( 0, N, NRHS, B, LDB, 0, 0 ) CALL ZTIMMG( 1, N, NRHS, C, LDB, 0, 0 ) IC = 0 S1 = DSECND( ) 90 CONTINUE IB = 1 DO 100 I = 1, NRHS CALL ZGBMV( 'No transpose', N, N, KL, KU, ONE, $ A( KU+1 ), LDA, B( IB ), 1, ONE, $ C( IB ), 1 ) IB = IB + LDB 100 CONTINUE S2 = DSECND( ) TIME = S2 - S1 IC = IC + 1 IF( TIME.LT.TIMMIN ) THEN CALL ZTIMMG( 1, N, NRHS, C, LDB, 0, 0 ) GO TO 90 END IF * * Subtract the time used in ZTIMMG. * ICL = 1 S1 = DSECND( ) 110 CONTINUE S2 = DSECND( ) UNTIME = S2 - S1 ICL = ICL + 1 IF( ICL.LE.IC ) THEN CALL ZTIMMG( 1, N, NRHS, C, LDB, 0, 0 ) GO TO 110 END IF * TIME = ( TIME-UNTIME ) / DBLE( IC ) OPS = NRHS*DOPBL2( 'ZGBMV ', N, N, KL, KU ) RESLTS( IN, IK, ILDA ) = DMFLOP( OPS, TIME, 0 ) 120 CONTINUE 130 CONTINUE 140 CONTINUE * CALL DPRTBL( LAB1, LAB2, NN, NVAL, NK, KVAL, NLDA, RESLTS, $ LDR1, LDR2, NOUT ) END IF * 150 CONTINUE 9999 FORMAT( 1X, A6, ': Unrecognized path or subroutine name', / ) 9998 FORMAT( 1X, A6, ' timing run not attempted', / ) 9997 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' ) 9996 FORMAT( 5X, 'with LDA = ', I5 ) 9995 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 ) RETURN * * End of ZTIMMV * END SHAR_EOF fi # end of overwriting check if test -f 'ztimqp.f' then echo shar: will not over-write existing file "'ztimqp.f'" else cat << SHAR_EOF > 'ztimqp.f' SUBROUTINE ZTIMQP( LINE, NM, MVAL, NVAL, NLDA, LDAVAL, TIMMIN, A, $ COPYA, TAU, WORK, RWORK, IWORK, RESLTS, LDR1, $ LDR2, NOUT ) * * -- LAPACK timing routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER*80 LINE INTEGER LDR1, LDR2, NLDA, NM, NOUT DOUBLE PRECISION TIMMIN * .. * .. Array Arguments .. INTEGER IWORK( * ), LDAVAL( * ), MVAL( * ), NVAL( * ) DOUBLE PRECISION RESLTS( LDR1, LDR2, * ), RWORK( * ) COMPLEX*16 A( * ), COPYA( * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZTIMQP times the LAPACK routines to perform the QR factorization with * column pivoting of a COMPLEX*16 general matrix. * * Two matrix types may be used for timing. The number of types is * set in the parameter NMODE and the matrix types are set in the vector * MODES, using the following key: * 2. BREAK1 D(1:N-1)=1 and D(N)=1.0/COND in ZLATMS * 3. GEOM D(I)=COND**(-(I-1)/(N-1)) in ZLATMS * These numbers are chosen to correspond with the matrix types in the * test code. * * Arguments * ========= * * LINE (input) CHARACTER*80 * The input line that requested this routine. The first six * characters contain either the name of a subroutine or a * generic path name. The remaining characters may be used to * specify the individual routines to be timed. See ATIMIN for * a full description of the format of the input line. * * NM (input) INTEGER * The number of values of M and N contained in the vectors * MVAL and NVAL. The matrix sizes are used in pairs (M,N). * * MVAL (input) INTEGER array, dimension (NM) * The values of the matrix row dimension M. * * NVAL (input) INTEGER array, dimension (NM) * The values of the matrix column dimension N. * * NLDA (input) INTEGER * The number of values of LDA contained in the vector LDAVAL. * * LDAVAL (input) INTEGER array, dimension (NLDA) * The values of the leading dimension of the array A. * * TIMMIN (input) DOUBLE PRECISION * The minimum time a subroutine will be timed. * * A (workspace) COMPLEX*16 array, dimension (LDAMAX*NMAX) * where LDAMAX and NMAX are the maximum values of LDA and N. * * COPYA (workspace) COMPLEX*16 array, dimension (LDAMAX*NMAX) * * TAU (workspace) COMPLEX*16 array, dimension (min(M,N)) * * WORK (workspace) COMPLEX*16 array, dimension (3*max(MMAX,NMAX)) * * RWORK (workspace) DOUBLE PRECISION array, dimension (2*NMAX) * * IWORK (workspace) INTEGER array, dimension (2*NMAX) * * RESLTS (workspace) DOUBLE PRECISION array, dimension * (LDR1,LDR2,NLDA) * The timing results for each subroutine over the relevant * values of MODE, (M,N), and LDA. * * LDR1 (input) INTEGER * The first dimension of RESLTS. LDR1 >= max(1,NM). * * LDR2 (input) INTEGER * The second dimension of RESLTS. LDR2 >= max(1,NM). * * NOUT (input) INTEGER * The unit number for output. * * ===================================================================== * * .. Parameters .. INTEGER NSUBS, NMODE PARAMETER ( NSUBS = 1, NMODE = 2 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. CHARACTER*3 PATH CHARACTER*6 CNAME INTEGER I, IC, ICL, ILDA, IM, IMODE, INFO, LDA, M, $ MINMN, MODE, N, NB DOUBLE PRECISION COND, DMAX, OPS, S1, S2, TIME, UNTIME * .. * .. Local Arrays .. LOGICAL TIMSUB( NSUBS ) CHARACTER*6 SUBNAM( NSUBS ) INTEGER ISEED( 4 ), MODES( NMODE ) * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DMFLOP, DOPLA, DSECND EXTERNAL DLAMCH, DMFLOP, DOPLA, DSECND * .. * .. External Subroutines .. EXTERNAL ATIMCK, ATIMIN, DPRTB5, ICOPY, ZGEQPF, ZLACPY, $ ZLATMS * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MIN * .. * .. Data statements .. DATA SUBNAM / 'ZGEQPF' / DATA MODES / 2, 3 / DATA ISEED / 0, 0, 0, 1 / * .. * .. Executable Statements .. * * Extract the timing request from the input line. * PATH( 1: 1 ) = 'Zomplex precision' PATH( 2: 3 ) = 'QP' CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO ) IF( .NOT.TIMSUB( 1 ) .OR. INFO.NE.0 ) $ GO TO 90 * * Check that M <= LDA for the input values. * CNAME = LINE( 1: 6 ) CALL ATIMCK( 1, CNAME, NM, MVAL, NLDA, LDAVAL, NOUT, INFO ) IF( INFO.GT.0 ) THEN WRITE( NOUT, FMT = 9999 )CNAME GO TO 90 END IF * * Set the condition number and scaling factor for the matrices * to be generated. * DMAX = ONE COND = ONE / DLAMCH( 'Precision' ) * * Do for each pair of values (M,N): * DO 60 IM = 1, NM M = MVAL( IM ) N = NVAL( IM ) MINMN = MIN( M, N ) * * Do for each value of LDA: * DO 50 ILDA = 1, NLDA LDA = LDAVAL( ILDA ) DO 40 IMODE = 1, NMODE MODE = MODES( IMODE ) * * Generate a test matrix of size m by n using the * singular value distribution indicated by MODE. * DO 10 I = 1, N IWORK( N+I ) = 0 10 CONTINUE CALL ZLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', RWORK, $ MODE, COND, DMAX, M, N, 'No packing', COPYA, $ LDA, WORK, INFO ) * * ZGEQPF: QR factorization with column pivoting * CALL ZLACPY( 'All', M, N, COPYA, LDA, A, LDA ) CALL ICOPY( N, IWORK( N+1 ), 1, IWORK, 1 ) IC = 0 S1 = DSECND( ) 20 CONTINUE CALL ZGEQPF( M, N, A, LDA, IWORK, TAU, WORK, RWORK, $ INFO ) S2 = DSECND( ) TIME = S2 - S1 IC = IC + 1 IF( TIME.LT.TIMMIN ) THEN CALL ZLACPY( 'All', M, N, COPYA, LDA, A, LDA ) CALL ICOPY( N, IWORK( N+1 ), 1, IWORK, 1 ) GO TO 20 END IF * * Subtract the time used in ZLACPY and ICOPY. * ICL = 1 S1 = DSECND( ) 30 CONTINUE S2 = DSECND( ) UNTIME = S2 - S1 ICL = ICL + 1 IF( ICL.LE.IC ) THEN CALL ZLACPY( 'All', M, N, COPYA, LDA, A, LDA ) CALL ICOPY( N, IWORK( N+1 ), 1, IWORK, 1 ) GO TO 30 END IF * TIME = ( TIME-UNTIME ) / DBLE( IC ) OPS = DOPLA( 'ZGEQPF', M, N, 0, 0, NB ) RESLTS( IMODE, IM, ILDA ) = DMFLOP( OPS, TIME, INFO ) * 40 CONTINUE 50 CONTINUE 60 CONTINUE * * Print tables of results * WRITE( NOUT, FMT = 9998 )SUBNAM( 1 ) IF( NLDA.GT.1 ) THEN DO 70 I = 1, NLDA WRITE( NOUT, FMT = 9997 )I, LDAVAL( I ) 70 CONTINUE END IF WRITE( NOUT, FMT = * ) CALL DPRTB5( 'Type', 'M', 'N', NMODE, MODES, NM, MVAL, NVAL, NLDA, $ RESLTS, LDR1, LDR2, NOUT ) 90 CONTINUE 9999 FORMAT( 1X, A6, ' timing run not attempted', / ) 9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' ) 9997 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 ) RETURN * * End of ZTIMQP * END SHAR_EOF fi # end of overwriting check if test -f 'ztimqr.f' then echo shar: will not over-write existing file "'ztimqr.f'" else cat << SHAR_EOF > 'ztimqr.f' SUBROUTINE ZTIMQR( LINE, NM, MVAL, NVAL, NK, KVAL, NNB, NBVAL, $ NXVAL, NLDA, LDAVAL, TIMMIN, A, TAU, B, WORK, $ RWORK, RESLTS, LDR1, LDR2, LDR3, NOUT ) * * -- LAPACK timing routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER*80 LINE INTEGER LDR1, LDR2, LDR3, NK, NLDA, NM, NNB, NOUT DOUBLE PRECISION TIMMIN * .. * .. Array Arguments .. INTEGER KVAL( * ), LDAVAL( * ), MVAL( * ), NBVAL( * ), $ NVAL( * ), NXVAL( * ) DOUBLE PRECISION RESLTS( LDR1, LDR2, LDR3, * ), RWORK( * ) COMPLEX*16 A( * ), B( * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZTIMQR times the LAPACK routines to perform the QR factorization of * a COMPLEX*16 general matrix. * * Arguments * ========= * * LINE (input) CHARACTER*80 * The input line that requested this routine. The first six * characters contain either the name of a subroutine or a * generic path name. The remaining characters may be used to * specify the individual routines to be timed. See ATIMIN for * a full description of the format of the input line. * * NM (input) INTEGER * The number of values of M and N contained in the vectors * MVAL and NVAL. The matrix sizes are used in pairs (M,N). * * MVAL (input) INTEGER array, dimension (NM) * The values of the matrix row dimension M. * * NVAL (input) INTEGER array, dimension (NM) * The values of the matrix column dimension N. * * NK (input) INTEGER * The number of values of K in the vector KVAL. * * KVAL (input) INTEGER array, dimension (NK) * The values of the matrix dimension K, used in ZUNMQR. * * NNB (input) INTEGER * The number of values of NB and NX contained in the * vectors NBVAL and NXVAL. The blocking parameters are used * in pairs (NB,NX). * * NBVAL (input) INTEGER array, dimension (NNB) * The values of the blocksize NB. * * NXVAL (input) INTEGER array, dimension (NNB) * The values of the crossover point NX. * * NLDA (input) INTEGER * The number of values of LDA contained in the vector LDAVAL. * * LDAVAL (input) INTEGER array, dimension (NLDA) * The values of the leading dimension of the array A. * * TIMMIN (input) DOUBLE PRECISION * The minimum time a subroutine will be timed. * * A (workspace) COMPLEX*16 array, dimension (LDAMAX*NMAX) * where LDAMAX and NMAX are the maximum values of LDA and N. * * TAU (workspace) COMPLEX*16 array, dimension (min(M,N)) * * B (workspace) COMPLEX*16 array, dimension (LDAMAX*NMAX) * * WORK (workspace) COMPLEX*16 array, dimension (LDAMAX*NBMAX) * where NBMAX is the maximum value of NB. * * RWORK (workspace) DOUBLE PRECISION array, dimension * (min(MMAX,NMAX)) * * RESLTS (workspace) DOUBLE PRECISION array, dimension * (LDR1,LDR2,LDR3,2*NK) * The timing results for each subroutine over the relevant * values of (M,N), (NB,NX), and LDA. * * LDR1 (input) INTEGER * The first dimension of RESLTS. LDR1 >= max(1,NNB). * * LDR2 (input) INTEGER * The second dimension of RESLTS. LDR2 >= max(1,NM). * * LDR3 (input) INTEGER * The third dimension of RESLTS. LDR3 >= max(1,NLDA). * * NOUT (input) INTEGER * The unit number for output. * * Internal Parameters * =================== * * MODE INTEGER * The matrix type. MODE = 3 is a geometric distribution of * eigenvalues. See ZLATMS for further details. * * COND DOUBLE PRECISION * The condition number of the matrix. The singular values are * set to values from DMAX to DMAX/COND. * * DMAX DOUBLE PRECISION * The magnitude of the largest singular value. * * ===================================================================== * * .. Parameters .. INTEGER NSUBS PARAMETER ( NSUBS = 3 ) INTEGER MODE DOUBLE PRECISION COND, DMAX PARAMETER ( MODE = 3, COND = 100.0D0, DMAX = 1.0D0 ) * .. * .. Local Scalars .. CHARACTER LABM, SIDE, TRANS CHARACTER*3 PATH CHARACTER*6 CNAME INTEGER I, I4, IC, ICL, IK, ILDA, IM, IMX, INB, INFO, $ ISIDE, ISUB, ITOFF, ITRAN, K, K1, LDA, LW, M, $ M1, MINMN, N, N1, NB, NX DOUBLE PRECISION OPS, S1, S2, TIME, UNTIME * .. * .. Local Arrays .. LOGICAL TIMSUB( NSUBS ) CHARACTER SIDES( 2 ), TRANSS( 2 ) CHARACTER*6 SUBNAM( NSUBS ) INTEGER ISEED( 4 ), MUSE( 12 ), NUSE( 12 ), RESEED( 4 ) * .. * .. External Functions .. DOUBLE PRECISION DMFLOP, DOPLA, DSECND EXTERNAL DMFLOP, DOPLA, DSECND * .. * .. External Subroutines .. EXTERNAL ATIMCK, ATIMIN, DPRTB4, DPRTB5, ICOPY, XLAENV, $ ZGEQRF, ZLACPY, ZLATMS, ZTIMMG, ZUNGQR, ZUNMQR * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN * .. * .. Data statements .. DATA SUBNAM / 'ZGEQRF', 'ZUNGQR', 'ZUNMQR' / DATA SIDES / 'L', 'R' / , TRANSS / 'N', 'C' / DATA ISEED / 0, 0, 0, 1 / * .. * .. Executable Statements .. * * Extract the timing request from the input line. * PATH( 1: 1 ) = 'Zomplex precision' PATH( 2: 3 ) = 'QR' CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO ) IF( INFO.NE.0 ) $ GO TO 230 * * Check that M <= LDA for the input values. * CNAME = LINE( 1: 6 ) CALL ATIMCK( 1, CNAME, NM, MVAL, NLDA, LDAVAL, NOUT, INFO ) IF( INFO.GT.0 ) THEN WRITE( NOUT, FMT = 9999 )CNAME GO TO 230 END IF * * Do for each pair of values (M,N): * DO 70 IM = 1, NM M = MVAL( IM ) N = NVAL( IM ) MINMN = MIN( M, N ) CALL ICOPY( 4, ISEED, 1, RESEED, 1 ) * * Do for each value of LDA: * DO 60 ILDA = 1, NLDA LDA = LDAVAL( ILDA ) * * Do for each pair of values (NB, NX) in NBVAL and NXVAL. * DO 50 INB = 1, NNB NB = NBVAL( INB ) CALL XLAENV( 1, NB ) NX = NXVAL( INB ) CALL XLAENV( 3, NX ) LW = MAX( 1, N*MAX( 1, NB ) ) CALL ICOPY( 4, RESEED, 1, ISEED, 1 ) * * Generate a test matrix of size M by N. * CALL ZLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', RWORK, $ MODE, COND, DMAX, M, N, 'No packing', B, $ LDA, WORK, INFO ) * IF( TIMSUB( 1 ) ) THEN * * ZGEQRF: QR factorization * CALL ZLACPY( 'Full', M, N, B, LDA, A, LDA ) IC = 0 S1 = DSECND( ) 10 CONTINUE CALL ZGEQRF( M, N, A, LDA, TAU, WORK, LW, INFO ) S2 = DSECND( ) TIME = S2 - S1 IC = IC + 1 IF( TIME.LT.TIMMIN ) THEN CALL ZLACPY( 'Full', M, N, B, LDA, A, LDA ) GO TO 10 END IF * * Subtract the time used in ZLACPY. * ICL = 1 S1 = DSECND( ) 20 CONTINUE S2 = DSECND( ) UNTIME = S2 - S1 ICL = ICL + 1 IF( ICL.LE.IC ) THEN CALL ZLACPY( 'Full', M, N, A, LDA, B, LDA ) GO TO 20 END IF * TIME = ( TIME-UNTIME ) / DBLE( IC ) OPS = DOPLA( 'ZGEQRF', M, N, 0, 0, NB ) RESLTS( INB, IM, ILDA, 1 ) = DMFLOP( OPS, TIME, INFO ) ELSE * * If ZGEQRF was not timed, generate a matrix and factor * it using ZGEQRF anyway so that the factored form of * the matrix can be used in timing the other routines. * CALL ZLACPY( 'Full', M, N, B, LDA, A, LDA ) CALL ZGEQRF( M, N, A, LDA, TAU, WORK, LW, INFO ) END IF * IF( TIMSUB( 2 ) ) THEN * * ZUNGQR: Generate orthogonal matrix Q from the QR * factorization * CALL ZLACPY( 'Full', M, MINMN, A, LDA, B, LDA ) IC = 0 S1 = DSECND( ) 30 CONTINUE CALL ZUNGQR( M, MINMN, MINMN, B, LDA, TAU, WORK, LW, $ INFO ) S2 = DSECND( ) TIME = S2 - S1 IC = IC + 1 IF( TIME.LT.TIMMIN ) THEN CALL ZLACPY( 'Full', M, MINMN, A, LDA, B, LDA ) GO TO 30 END IF * * Subtract the time used in ZLACPY. * ICL = 1 S1 = DSECND( ) 40 CONTINUE S2 = DSECND( ) UNTIME = S2 - S1 ICL = ICL + 1 IF( ICL.LE.IC ) THEN CALL ZLACPY( 'Full', M, MINMN, A, LDA, B, LDA ) GO TO 40 END IF * TIME = ( TIME-UNTIME ) / DBLE( IC ) OPS = DOPLA( 'ZUNGQR', M, MINMN, MINMN, 0, NB ) RESLTS( INB, IM, ILDA, 2 ) = DMFLOP( OPS, TIME, INFO ) END IF * 50 CONTINUE 60 CONTINUE 70 CONTINUE * * Print tables of results * DO 90 ISUB = 1, NSUBS - 1 IF( .NOT.TIMSUB( ISUB ) ) $ GO TO 90 WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB ) IF( NLDA.GT.1 ) THEN DO 80 I = 1, NLDA WRITE( NOUT, FMT = 9997 )I, LDAVAL( I ) 80 CONTINUE END IF WRITE( NOUT, FMT = * ) IF( ISUB.EQ.2 ) $ WRITE( NOUT, FMT = 9996 ) CALL DPRTB4( '( NB, NX)', 'M', 'N', NNB, NBVAL, NXVAL, NM, $ MVAL, NVAL, NLDA, RESLTS( 1, 1, 1, ISUB ), LDR1, $ LDR2, NOUT ) 90 CONTINUE * * Time ZUNMQR separately. Here the starting matrix is M by N, and * K is the free dimension of the matrix multiplied by Q. * IF( TIMSUB( 3 ) ) THEN * * Check that K <= LDA for the input values. * CALL ATIMCK( 3, CNAME, NK, KVAL, NLDA, LDAVAL, NOUT, INFO ) IF( INFO.GT.0 ) THEN WRITE( NOUT, FMT = 9999 )SUBNAM( 3 ) GO TO 230 END IF * * Use only the pairs (M,N) where M >= N. * IMX = 0 DO 100 IM = 1, NM IF( MVAL( IM ).GE.NVAL( IM ) ) THEN IMX = IMX + 1 MUSE( IMX ) = MVAL( IM ) NUSE( IMX ) = NVAL( IM ) END IF 100 CONTINUE * * ZUNMQR: Multiply by Q stored as a product of elementary * transformations * * Do for each pair of values (M,N): * DO 180 IM = 1, IMX M = MUSE( IM ) N = NUSE( IM ) * * Do for each value of LDA: * DO 170 ILDA = 1, NLDA LDA = LDAVAL( ILDA ) * * Generate an M by N matrix and form its QR decomposition. * CALL ZLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', RWORK, $ MODE, COND, DMAX, M, N, 'No packing', A, $ LDA, WORK, INFO ) LW = MAX( 1, N*MAX( 1, NB ) ) CALL ZGEQRF( M, N, A, LDA, TAU, WORK, LW, INFO ) * * Do first for SIDE = 'L', then for SIDE = 'R' * I4 = 0 DO 160 ISIDE = 1, 2 SIDE = SIDES( ISIDE ) * * Do for each pair of values (NB, NX) in NBVAL and * NXVAL. * DO 150 INB = 1, NNB NB = NBVAL( INB ) CALL XLAENV( 1, NB ) NX = NXVAL( INB ) CALL XLAENV( 3, NX ) * * Do for each value of K in KVAL * DO 140 IK = 1, NK K = KVAL( IK ) * * Sort out which variable is which * IF( ISIDE.EQ.1 ) THEN M1 = M K1 = N N1 = K LW = MAX( 1, N1*MAX( 1, NB ) ) ELSE N1 = M K1 = N M1 = K LW = MAX( 1, M1*MAX( 1, NB ) ) END IF * * Do first for TRANS = 'N', then for TRANS = 'T' * ITOFF = 0 DO 130 ITRAN = 1, 2 TRANS = TRANSS( ITRAN ) CALL ZTIMMG( 0, M1, N1, B, LDA, 0, 0 ) IC = 0 S1 = DSECND( ) 110 CONTINUE CALL ZUNMQR( SIDE, TRANS, M1, N1, K1, A, LDA, $ TAU, B, LDA, WORK, LW, INFO ) S2 = DSECND( ) TIME = S2 - S1 IC = IC + 1 IF( TIME.LT.TIMMIN ) THEN CALL ZTIMMG( 0, M1, N1, B, LDA, 0, 0 ) GO TO 110 END IF * * Subtract the time used in ZTIMMG. * ICL = 1 S1 = DSECND( ) 120 CONTINUE S2 = DSECND( ) UNTIME = S2 - S1 ICL = ICL + 1 IF( ICL.LE.IC ) THEN CALL ZTIMMG( 0, M1, N1, B, LDA, 0, 0 ) GO TO 120 END IF * TIME = ( TIME-UNTIME ) / DBLE( IC ) OPS = DOPLA( 'ZUNMQR', M1, N1, K1, ISIDE-1, $ NB ) RESLTS( INB, IM, ILDA, $ I4+ITOFF+IK ) = DMFLOP( OPS, TIME, INFO ) ITOFF = NK 130 CONTINUE 140 CONTINUE 150 CONTINUE I4 = 2*NK 160 CONTINUE 170 CONTINUE 180 CONTINUE * * Print tables of results * ISUB = 3 I4 = 1 IF( IMX.GE.1 ) THEN DO 220 ISIDE = 1, 2 SIDE = SIDES( ISIDE ) IF( ISIDE.EQ.1 ) THEN WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB ) IF( NLDA.GT.1 ) THEN DO 190 I = 1, NLDA WRITE( NOUT, FMT = 9997 )I, LDAVAL( I ) 190 CONTINUE END IF END IF DO 210 ITRAN = 1, 2 TRANS = TRANSS( ITRAN ) DO 200 IK = 1, NK IF( ISIDE.EQ.1 ) THEN N = KVAL( IK ) WRITE( NOUT, FMT = 9995 )SUBNAM( ISUB ), SIDE, $ TRANS, 'N', N LABM = 'M' ELSE M = KVAL( IK ) WRITE( NOUT, FMT = 9995 )SUBNAM( ISUB ), SIDE, $ TRANS, 'M', M LABM = 'N' END IF CALL DPRTB5( 'NB', LABM, 'K', NNB, NBVAL, IMX, $ MUSE, NUSE, NLDA, $ RESLTS( 1, 1, 1, I4 ), LDR1, LDR2, $ NOUT ) I4 = I4 + 1 200 CONTINUE 210 CONTINUE 220 CONTINUE ELSE WRITE( NOUT, FMT = 9994 )SUBNAM( ISUB ) END IF END IF 230 CONTINUE 9999 FORMAT( 1X, A6, ' timing run not attempted', / ) 9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' ) 9997 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 ) 9996 FORMAT( 5X, 'K = min(M,N)', / ) 9995 FORMAT( / 5X, A6, ' with SIDE = ''', A1, ''', TRANS = ''', A1, $ ''', ', A1, ' =', I6, / ) 9994 FORMAT( ' *** No pairs (M,N) found with M >= N: ', A6, $ ' not timed' ) RETURN * * End of ZTIMQR * END SHAR_EOF fi # end of overwriting check if test -f 'ztimrr.f' then echo shar: will not over-write existing file "'ztimrr.f'" else cat << SHAR_EOF > 'ztimrr.f' SUBROUTINE ZTIMRR( LINE, NM, MVAL, NVAL, NK, KVAL, $ NNB, NBVAL, NXVAL, NLDA, LDAVAL, TIMMIN, $ A, COPYA, B, WORK, RWORK, IWORK, RESLTS, $ LDR1, LDR2, NOUT ) * * -- LAPACK timing routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * Rewritten for timing rrqr code. * * .. Scalar Arguments .. CHARACTER*80 LINE INTEGER LDR1, LDR2, NK, NLDA, NM, NNB, NOUT DOUBLE PRECISION TIMMIN * .. * .. Array Arguments .. INTEGER IWORK( * ), KVAL( * ), LDAVAL( * ), MVAL( * ), $ NBVAL( * ), NVAL( * ), NXVAL( * ) DOUBLE PRECISION RESLTS( LDR1, LDR2, * ), RWORK( * ) COMPLEX*16 A( * ), COPYA( * ), B( * ), WORK( * ) * .. * * Purpose * ======= * * ZTIMRR times the Rank-Revealing QR factorization of a * COMPLEX*16 general matrix. * * Two matrix types may be used for timing. The number of types is * set in the parameter NMODE and the matrix types are set in the vector * MODES, using the following key: * 2. BREAK1 D(1:N-1)=1 and D(N)=1.0/COND in ZLATMS * 3. GEOM D(I)=COND**(-(I-1)/(N-1)) in ZLATMS * These numbers are chosen to correspond with the matrix types in the * test code. * * Arguments * ========= * * LINE (input) CHARACTER*80 * The input line that requested this routine. The first six * characters contain either the name of a subroutine or a * generic path name. The remaining characters may be used to * specify the individual routines to be timed. See ATIMIN for * a full description of the format of the input line. * * NM (input) INTEGER * The number of values of M and N contained in the vectors * MVAL and NVAL. The matrix sizes are used in pairs (M,N). * * MVAL (input) INTEGER array, dimension (NM) * The values of the matrix row dimension M. * * NVAL (input) INTEGER array, dimension (NM) * The values of the matrix column dimension N. * * NK (input) INTEGER * The number of values of K in the vector KVAL. * * KVAL (input) INTEGER array, dimension (NK) * The values of the matrix dimension K, used in SORMQR. * * NNB (input) INTEGER * The number of values of NB and NX contained in the * vectors NBVAL and NXVAL. The blocking parameters are used * in pairs (NB,NX). * * NBVAL (input) INTEGER array, dimension (NNB) * The values of the blocksize NB. * * NXVAL (input) INTEGER array, dimension (NNB) * The values of the crossover point NX. * * NLDA (input) INTEGER * The number of values of LDA contained in the vector LDAVAL. * * LDAVAL (input) INTEGER array, dimension (NLDA) * The values of the leading dimension of the array A. * * TIMMIN (input) DOUBLE PRECISION * The minimum time a subroutine will be timed. * * A (workspace) COMPLEX*16 array, dimension (LDAMAX*NMAX) * where LDAMAX and NMAX are the maximum values of LDA and N. * * COPYA (workspace) COMPLEX*16 array, dimension (LDAMAX*NMAX) * * B (workspace) COMPLEX*16 array, dimension (LDAMAX*NMAX) * * * WORK (workspace) COMPLEX*16 array, dimension (3*max(MMAX,NMAX)) * * RWORK (workspace) DOUBLE PRECISION array, dimension (2*NMAX) * * IWORK (workspace) INTEGER array, dimension (NMAX) * * RESLTS (workspace) DOUBLE PRECISION array, dimension * (LDR1,LDR2,NLDA) * The timing results for each subroutine over the relevant * values of MODE, (M,N), and LDA. * * LDR1 (input) INTEGER * The first dimension of RESLTS. LDR1 >= max(1,NM). * * LDR2 (input) INTEGER * The second dimension of RESLTS. LDR2 >= max(1,NM). * * NOUT (input) INTEGER * The unit number for output. * * ===================================================================== * * .. Parameters .. INTEGER NSUBS, NMODE PARAMETER ( NSUBS = 2, NMODE = 2 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. CHARACTER*3 PATH CHARACTER*6 CNAME INTEGER I, IC, ICL, ILDA, IM, IMODE, INB, INFO, IK, $ JOB, K, LDA, LW, M, MINMN, MODE, N, NX, NB, $ RANK DOUBLE PRECISION COND, DMAX, OPS, IRCOND, ORCOND, S1, S2, $ TIME, UNTIME * .. * .. Local Arrays .. LOGICAL TIMSUB( NSUBS ) CHARACTER*6 SUBNAM( NSUBS ) INTEGER ISEED( 4 ), MODES( NMODE ) DOUBLE PRECISION SVLUES( 4 ) * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DMFLOP, DOPLA, DSECND EXTERNAL DLAMCH, DMFLOP, DOPLA, DSECND * .. * .. External Subroutines .. EXTERNAL ATIMCK, ATIMIN, ZGEQPX, ZGEQPY, $ ZLACPY, ZLATMS * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MIN * .. * .. Data statements .. DATA SUBNAM / 'ZGEQPX', 'ZGEQPY' / DATA MODES / 2, 3 / DATA ISEED / 0, 0, 0, 1 / * .. * .. Executable Statements .. * * Extract the timing request from the input line. * PATH( 1: 1 ) = 'Zomplex precision' PATH( 2: 3 ) = 'RR' CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO ) IF( .NOT.TIMSUB( 1 ) .OR. INFO.NE.0 ) $ GO TO 1000 * * Check that M <= LDA for the input values. * CNAME = LINE( 1: 6 ) CALL ATIMCK( 1, CNAME, NM, MVAL, NLDA, LDAVAL, NOUT, INFO ) IF( INFO.GT.0 ) THEN WRITE( NOUT, FMT = 9999 )CNAME GO TO 1000 END IF * * Set the condition number and scaling factor for the matrices * to be generated. * DMAX = ONE IRCOND = DLAMCH( 'Precision' ) COND = ONE / IRCOND * * Do for each value of K: * DO 10 IK = 1, NK K = KVAL( IK ) IF( K.EQ.0 ) THEN JOB = 1 ELSE JOB = 2 END IF * * Do for each type of matrix: * DO 20 IMODE = 1, NMODE MODE = MODES( IMODE ) * * * ***************** * * Timing xGEQPX * * ***************** * * Do for each value of LDA: * DO 30 ILDA = 1, NLDA LDA = LDAVAL( ILDA ) * * Do for each pair of values (M,N): * DO 40 IM = 1, NM M = MVAL( IM ) N = NVAL( IM ) MINMN = MIN( M, N ) * * Generate a test matrix of size m by n using the * singular value distribution indicated by MODE. * CALL ZLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', $ RWORK, MODE, COND, DMAX, M, N, $ 'No packing', COPYA, LDA, WORK, INFO ) * * Do for each pair of values ( NB, NX ) in NBVAL and NXVAL: * DO 50 INB = 1, NNB NB = NBVAL( INB ) CALL XLAENV( 1, NB ) NX = NXVAL( INB ) CALL XLAENV( 3, NX ) * IF( JOB.EQ.1 ) THEN IF( NB.LT.3 ) THEN LW = MAX( 1, 2*MINMN+3*N ) ELSE LW = MAX( 1, 2*MINMN+NB*N ) END IF ELSE IF( NB.LT.3 ) THEN LW = MAX( 1, 2*MINMN+2*N+MAX(K,N) ) ELSE LW = MAX( 1, 2*MINMN+NB*NB+NB*MAX(K,N) ) END IF END IF * * ZGEQPX: RRQR factorization * CALL ZLACPY( 'All', M, N, COPYA, LDA, A, LDA ) IC = 0 S1 = DSECND( ) 60 CONTINUE * CALL ZGEQPX( JOB, M, N, K, A, LDA, B, LDA, $ IWORK, IRCOND, ORCOND, RANK, SVLUES, $ WORK, LW, RWORK, INFO ) S2 = DSECND( ) * IF( INFO.NE.0 ) THEN WRITE( *,* ) '>>>Warning: INFO returned by ', $ 'ZGEQPX is:', INFO INFO = 0 END IF * TIME = S2 - S1 IC = IC + 1 IF( TIME.LT.TIMMIN ) THEN CALL ZLACPY( 'All', M, N, COPYA, LDA, $ A, LDA ) GO TO 60 END IF * * Subtract the time used in ZLACPY. * ICL = 1 S1 = DSECND( ) 70 CONTINUE S2 = DSECND( ) UNTIME = S2 - S1 ICL = ICL + 1 IF( ICL.LE.IC ) THEN CALL ZLACPY( 'All', M, N, COPYA, LDA, $ A, LDA ) GO TO 70 END IF * TIME = ( TIME-UNTIME ) / DBLE( IC ) * * The number of flops of yGEQPX is approximately the * the number of flops of yGEQPF plus the number of * flops required by yUNMQR to update matrix C. * OPS = DOPLA( 'ZGEQPF', M, N, 0, 0, NB ) $ + DOPLA( 'ZUNMQR', M, K, MINMN, 0, NB ) RESLTS( INB, IM, ILDA ) = $ DMFLOP( OPS, TIME, INFO ) * 50 CONTINUE 40 CONTINUE 30 CONTINUE * * Print the results for each value of K and type of matrix. * WRITE( NOUT, FMT = 9995 )SUBNAM( 1 ) WRITE( NOUT, FMT = 9996 )K, IMODE DO 90 I = 1, NLDA WRITE( NOUT, FMT = 9997 )I,LDAVAL( I ) 90 CONTINUE WRITE( NOUT, FMT = * ) CALL DPRTB4( '( NB, NX)', 'M', 'N', NNB, NBVAL, $ NXVAL, NM, MVAL, NVAL, NLDA, RESLTS( 1, 1, 1 ), $ LDR1, LDR2, NOUT ) * * * ***************** * * Timing xGEQPY * * ***************** * * Do for each value of LDA: * DO 200 ILDA = 1, NLDA LDA = LDAVAL( ILDA ) * * Do for each pair of values (M,N): * DO 210 IM = 1, NM M = MVAL( IM ) N = NVAL( IM ) MINMN = MIN( M, N ) * * Generate a test matrix of size m by n using the * singular value distribution indicated by MODE. * CALL ZLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', $ RWORK, MODE, COND, DMAX, M, N, $ 'No packing', COPYA, LDA, WORK, INFO ) * * Do for each pair of values ( NB, NX ) in NBVAL and NXVAL: * DO 220 INB = 1, NNB NB = NBVAL( INB ) CALL XLAENV( 1, NB ) NX = NXVAL( INB ) CALL XLAENV( 3, NX ) * IF( JOB.EQ.1 ) THEN IF( NB.LT.3 ) THEN LW = MAX( 1, 2*MINMN+3*N ) ELSE LW = MAX( 1, 2*MINMN+NB*N ) END IF ELSE IF( NB.LT.3 ) THEN LW = MAX( 1, 2*MINMN+2*N+MAX(K,N) ) ELSE LW = MAX( 1, 2*MINMN+NB*NB+NB*MAX(K,N) ) END IF END IF * * ZGEQPY: RRQR factorization * CALL ZLACPY( 'All', M, N, COPYA, LDA, A, LDA ) IC = 0 S1 = DSECND( ) 230 CONTINUE * CALL ZGEQPY( JOB, M, N, K, A, LDA, B, LDA, $ IWORK, IRCOND, ORCOND, RANK, SVLUES, $ WORK, LW, RWORK, INFO ) S2 = DSECND( ) * IF( INFO.NE.0 ) THEN WRITE( *,* ) '>>>Warning: INFO returned by ', $ 'ZGEQPY is:', INFO INFO = 0 END IF * TIME = S2 - S1 IC = IC + 1 IF( TIME.LT.TIMMIN ) THEN CALL ZLACPY( 'All', M, N, COPYA, LDA, $ A, LDA ) GO TO 230 END IF * * Subtract the time used in ZLACPY. * ICL = 1 S1 = DSECND( ) 240 CONTINUE S2 = DSECND( ) UNTIME = S2 - S1 ICL = ICL + 1 IF( ICL.LE.IC ) THEN CALL ZLACPY( 'All', M, N, COPYA, LDA, $ A, LDA ) GO TO 240 END IF * * The number of flops of yGEQPY is approximately the * the number of flops of yGEQPF plus the number of * flops required by yUNMQR to update matrix C. * TIME = ( TIME-UNTIME ) / DBLE( IC ) * OPS = DOPLA( 'ZGEQPF', M, N, 0, 0, NB ) $ + DOPLA( 'ZUNMQR', M, K, MINMN, 0, NB ) RESLTS( INB, IM, ILDA ) = $ DMFLOP( OPS, TIME, INFO ) * 220 CONTINUE 210 CONTINUE 200 CONTINUE * * Print the results for each value of K and type of matrix. * WRITE( NOUT, FMT = 9995 )SUBNAM( 2 ) WRITE( NOUT, FMT = 9996 )K, IMODE DO 250 I = 1, NLDA WRITE( NOUT, FMT = 9997 )I,LDAVAL( I ) 250 CONTINUE WRITE( NOUT, FMT = * ) CALL DPRTB4( '( NB, NX)', 'M', 'N', NNB, NBVAL, $ NXVAL, NM, MVAL, NVAL, NLDA, RESLTS( 1, 1, 1 ), $ LDR1, LDR2, NOUT ) * * 20 CONTINUE 10 CONTINUE * 9995 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' ) 9996 FORMAT( 5X, 'with K = ', I4, ' and type of matrix:', I4 ) 9997 FORMAT( 5X, 'line ', I4, ' with LDA = ', I4 ) 9999 FORMAT( 1X, A6, ' timing run not attempted', / ) * 1000 CONTINUE RETURN * * End of ZTIMRR * END SHAR_EOF fi # end of overwriting check cd .. if test -f 'ztime.lg.in' then echo shar: will not over-write existing file "'ztime.lg.in'" else cat << SHAR_EOF > 'ztime.lg.in' RRQR timing, COMPLEX*16 square matrices 1 Number of values of M 1000 Values of M (row dimension) 1 Number of values of N 1000 Values of N (column dimension) 1 Number of values of K 0 Values of K 3 Number of values of NB 1 16 32 Values of NB (blocksize) 0 0 0 Values of NX (crossover point) 2 Number of values of LDA 1000 1001 Values of LDA (leading dimension) 0.5 Minimum time in seconds ZQR T T F ZQP T ZRR T SHAR_EOF fi # end of overwriting check if test -f 'ztime.me.in' then echo shar: will not over-write existing file "'ztime.me.in'" else cat << SHAR_EOF > 'ztime.me.in' RRQR timing, COMPLEX*16 square matrices 1 Number of values of M 500 Values of M (row dimension) 1 Number of values of N 500 Values of N (column dimension) 1 Number of values of K 0 Values of K 3 Number of values of NB 1 16 32 Values of NB (blocksize) 0 0 0 Values of NX (crossover point) 2 Number of values of LDA 500 501 Values of LDA (leading dimension) 0.5 Minimum time in seconds ZQR T T F ZQP T ZRR T SHAR_EOF fi # end of overwriting check if test -f 'ztime.sm.in' then echo shar: will not over-write existing file "'ztime.sm.in'" else cat << SHAR_EOF > 'ztime.sm.in' RRQR timing, COMPLEX*16 square matrices 1 Number of values of M 100 Values of M (row dimension) 1 Number of values of N 100 Values of N (column dimension) 1 Number of values of K 0 Values of K 4 Number of values of NB 1 8 12 20 Values of NB (blocksize) 0 0 0 0 Values of NX (crossover point) 2 Number of values of LDA 100 101 Values of LDA (leading dimension) 0.5 Minimum time in seconds ZQR T T F ZQP T ZRR T SHAR_EOF fi # end of overwriting check cd .. if test ! -d 'v15.acm' then mkdir 'v15.acm' fi cd 'v15.acm' if test -f 'Dqr.in' then echo shar: will not over-write existing file "'Dqr.in'" else cat << SHAR_EOF > 'Dqr.in' 'hp' name of output file 1 how many values for m 50 values for m (on one line) 1 how many values for n 50 values for n (on one line <= 2*m) 7 how many block sizes 1 5 8 12 16 20 24 block sizes 3 number of different test matrix generators called 1 2 3 1 => xGNTST, 2 => xQRMTX, 3 => xLATMS 7 number of test cases for xGNTST 1 2 3 4 5 6 7 test cases for xGNTST (number between 1 and 7) 6 number of singular value distr. for xQRMTX 2 -2 3 -3 4 -4 +-2 => break1, +-3 => geometric, +-4 => arithmetic 6 number of singular value distr. for xLATMS 2 -2 3 -3 4 -4 +-2 => break1, +-3 => geometric, +-4 => arithmetic 3 strip width for xGNTST and xQRMTX 1 this root of epsilon is taken to multiply dep. cols. with in xQRMTX 1d-5 inverse of accept. threshold for condition number 50 gap around acceptance threshold 0.0 minimum time for a benchmark run to be valid 1126 2069 3441 1007 seed for random number generator SHAR_EOF fi # end of overwriting check 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' then echo shar: will not over-write existing file "'Makefile'" else cat << SHAR_EOF > 'Makefile' # # Makefile for generating single and double precision routines # for rrqr factorization. # # *********************************************** # * Authors: C.H.Bischof and G.Quintana-Orti * # * * # *********************************************** # # To be set in command line: # ========================= .SUFFIX: P = s # Precision (s or d). FORTRAN = f77 # Fortran compiler. OPTS = -u -dalign # Fortran compiler optimizing options. LOADER = f77 # Fortran linker. LOADOPTS = -O -dalign # Fortran linker optimizing options. LAPACKLIB = /usr/local/lib/lapack/lapack-2.a # Name of libraries # supplying LAPACK # solvers. TMGLIB = /usr/local/lib/lapack/tmglib-2.a # Name of libraries # supplying LAPACK # test matrix # generation suite. BLASLIB = /usr/local/lib/lapack/blas.a # Name of libraries # supplying BLAS. SHELL = /bin/csh OBJECTS = $(P)qr.o \ $(P)geqpx.o $(P)trqpx.o $(P)trqxc.o \ $(P)geqpy.o $(P)trqpy.o $(P)trqyc.o \ $(P)geqpb.o $(P)geqpw.o $(P)geqpc.o \ $(P)mylap.o \ $(P)trrnk.o $(P)lasmx.o $(P)lauc1.o \ $(P)gntst.o $(P)qrmtx.o \ $(P)utils.o \ ilaenv.o \ esm.o # -- Main Target -- # ****************** $(P)qr: $(OBJECTS) $(LOADER) $(LOADOPTS) -o $@ $(OBJECTS) \ $(TMGLIB) $(LAPACKLIB) $(BLASLIB) # -- Rules for generating objects -- # ********************************** qr.o: echo $(P)qr .f.o: $(FORTRAN) -c $(OPTS) $*.f # -- Rules for cleaning the source and object files -- # **************************************************** clean: cleanup cleanout cleanup: - rm -f sqr_* dqr_* *.o cleanout: - rm -f out out.* time.* rank.* ftrace.* *.trace core 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: # CPP = /lib/cpp CPPFLAGS = "-DHP -I../../v15" REAL_SOURCES = ../../v15 GENERATE = ../generate # ####################################################################### ####################################################################### # # Modules for Rank-Revealing QR: # S_RRQR_MODULES = \ sgeqpb.f sgeqpw.f sgeqpc.f \ sgeqpx.f strqpx.f strqxc.f \ sgeqpy.f strqpy.f strqyc.f \ strrnk.f slauc1.f slasmx.f \ smylap.f D_RRQR_MODULES = \ dgeqpb.f dgeqpw.f dgeqpc.f \ dgeqpx.f dtrqpx.f dtrqxc.f \ dgeqpy.f dtrqpy.f dtrqyc.f \ dtrrnk.f dlauc1.f dlasmx.f \ dmylap.f S_PROGRRQR_MODULES = \ sqr.f esm.f sutils.f sgntst.f sqrmtx.f D_PROGRRQR_MODULES = \ dqr.f dutils.f dgntst.f dqrmtx.f COMMON_FILES = \ ilaenv.f # # ####################################################################### source: single double single: $(S_PROGRRQR_MODULES) $(S_RRQR_MODULES) $(H_FILES) $(COMMON_FILES) double: $(D_PROGRRQR_MODULES) $(D_RRQR_MODULES) $(H_FILES) $(COMMON_FILES) ilaenv.f: $(REAL_SOURCES)/ilaenv.F cp $(REAL_SOURCES)/ilaenv.F ilaenv.f # # Rules for REAL SINGLE PRECISION RRQR code. # sqr.f: $(REAL_SOURCES)/xqr.F $(GENERATE) s $(REAL_SOURCES)/xqr.F $@ $(CPP) $(CPPFLAGS) sgntst.f: $(REAL_SOURCES)/xgntst.F $(GENERATE) s $(REAL_SOURCES)/xgntst.F $@ $(CPP) $(CPPFLAGS) sqrmtx.f: $(REAL_SOURCES)/xqrmtx.F $(GENERATE) s $(REAL_SOURCES)/xqrmtx.F $@ $(CPP) $(CPPFLAGS) sutils.f: $(REAL_SOURCES)/xutils.F $(GENERATE) s $(REAL_SOURCES)/xutils.F $@ $(CPP) $(CPPFLAGS) esm.f: $(REAL_SOURCES)/esm.F cp $(REAL_SOURCES)/esm.F esm.f sgeqpb.f: $(REAL_SOURCES)/xgeqpb.F $(GENERATE) s $(REAL_SOURCES)/xgeqpb.F $@ $(CPP) $(CPPFLAGS) sgeqpw.f: $(REAL_SOURCES)/xgeqpw.F $(GENERATE) s $(REAL_SOURCES)/xgeqpw.F $@ $(CPP) $(CPPFLAGS) sgeqpc.f: $(REAL_SOURCES)/xgeqpc.F $(GENERATE) s $(REAL_SOURCES)/xgeqpc.F $@ $(CPP) $(CPPFLAGS) sgeqpx.f: $(REAL_SOURCES)/xgeqpx.F $(GENERATE) s $(REAL_SOURCES)/xgeqpx.F $@ $(CPP) $(CPPFLAGS) strqpx.f: $(REAL_SOURCES)/xtrqpx.F $(GENERATE) s $(REAL_SOURCES)/xtrqpx.F $@ $(CPP) $(CPPFLAGS) strqxc.f: $(REAL_SOURCES)/xtrqxc.F $(GENERATE) s $(REAL_SOURCES)/xtrqxc.F $@ $(CPP) $(CPPFLAGS) sgeqpy.f: $(REAL_SOURCES)/xgeqpy.F $(GENERATE) s $(REAL_SOURCES)/xgeqpy.F $@ $(CPP) $(CPPFLAGS) strqpy.f: $(REAL_SOURCES)/xtrqpy.F $(GENERATE) s $(REAL_SOURCES)/xtrqpy.F $@ $(CPP) $(CPPFLAGS) strqyc.f: $(REAL_SOURCES)/xtrqyc.F $(GENERATE) s $(REAL_SOURCES)/xtrqyc.F $@ $(CPP) $(CPPFLAGS) strrnk.f: $(REAL_SOURCES)/xtrrnk.F $(GENERATE) s $(REAL_SOURCES)/xtrrnk.F $@ $(CPP) $(CPPFLAGS) slauc1.f: $(REAL_SOURCES)/xlauc1.F $(GENERATE) s $(REAL_SOURCES)/xlauc1.F $@ $(CPP) $(CPPFLAGS) slasmx.f: $(REAL_SOURCES)/xlasmx.F $(GENERATE) s $(REAL_SOURCES)/xlasmx.F $@ $(CPP) $(CPPFLAGS) smylap.f: $(REAL_SOURCES)/smylap.f cp $(REAL_SOURCES)/smylap.f . # # Rules for REAL DOUBLE PRECISION RRQR code. # dqr.f: $(REAL_SOURCES)/xqr.F $(GENERATE) d $(REAL_SOURCES)/xqr.F $@ $(CPP) $(CPPFLAGS) dgntst.f: $(REAL_SOURCES)/xgntst.F $(GENERATE) d $(REAL_SOURCES)/xgntst.F $@ $(CPP) $(CPPFLAGS) dqrmtx.f: $(REAL_SOURCES)/xqrmtx.F $(GENERATE) d $(REAL_SOURCES)/xqrmtx.F $@ $(CPP) $(CPPFLAGS) dutils.f: $(REAL_SOURCES)/xutils.F $(GENERATE) d $(REAL_SOURCES)/xutils.F $@ $(CPP) $(CPPFLAGS) dgeqpb.f: $(REAL_SOURCES)/xgeqpb.F $(GENERATE) d $(REAL_SOURCES)/xgeqpb.F $@ $(CPP) $(CPPFLAGS) dgeqpw.f: $(REAL_SOURCES)/xgeqpw.F $(GENERATE) d $(REAL_SOURCES)/xgeqpw.F $@ $(CPP) $(CPPFLAGS) dgeqpc.f: $(REAL_SOURCES)/xgeqpc.F $(GENERATE) d $(REAL_SOURCES)/xgeqpc.F $@ $(CPP) $(CPPFLAGS) dgeqpx.f: $(REAL_SOURCES)/xgeqpx.F $(GENERATE) d $(REAL_SOURCES)/xgeqpx.F $@ $(CPP) $(CPPFLAGS) dtrqpx.f: $(REAL_SOURCES)/xtrqpx.F $(GENERATE) d $(REAL_SOURCES)/xtrqpx.F $@ $(CPP) $(CPPFLAGS) dtrqxc.f: $(REAL_SOURCES)/xtrqxc.F $(GENERATE) d $(REAL_SOURCES)/xtrqxc.F $@ $(CPP) $(CPPFLAGS) dgeqpy.f: $(REAL_SOURCES)/xgeqpy.F $(GENERATE) d $(REAL_SOURCES)/xgeqpy.F $@ $(CPP) $(CPPFLAGS) dtrqpy.f: $(REAL_SOURCES)/xtrqpy.F $(GENERATE) d $(REAL_SOURCES)/xtrqpy.F $@ $(CPP) $(CPPFLAGS) dtrqyc.f: $(REAL_SOURCES)/xtrqyc.F $(GENERATE) d $(REAL_SOURCES)/xtrqyc.F $@ $(CPP) $(CPPFLAGS) dtrrnk.f: $(REAL_SOURCES)/xtrrnk.F $(GENERATE) d $(REAL_SOURCES)/xtrrnk.F $@ $(CPP) $(CPPFLAGS) dlauc1.f: $(REAL_SOURCES)/xlauc1.F $(GENERATE) d $(REAL_SOURCES)/xlauc1.F $@ $(CPP) $(CPPFLAGS) dlasmx.f: $(REAL_SOURCES)/xlasmx.F $(GENERATE) d $(REAL_SOURCES)/xlasmx.F $@ $(CPP) $(CPPFLAGS) dmylap.f: $(REAL_SOURCES)/dmylap.f cp $(REAL_SOURCES)/dmylap.f . # # Clean rules. # clean: - rm -f *.f *.h *.o SHAR_EOF fi # end of overwriting check 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. * * * ******************************************************************************* Using the driver in this directory: =================================== This directory contains the testing/timing drivers used to get the timings published in technical report "Argonne Preprint ANL-MCS-P559-0196" and submitted to ACM TOMS. Note: Take care with matrix dimensions. The current code is prepared to run with up to 500x500 matrices. If you want to run it with larger matrices, you should change constant NMAX in xqr.f files. SHAR_EOF fi # end of overwriting check if test -f 'REVISIONS' then echo shar: will not over-write existing file "'REVISIONS'" else cat << SHAR_EOF > 'REVISIONS' Revision 0: ========== Distributed to Anna Tsao, Zhaoujun Bai, and Mehmet at Northwestern U. It works with the release of LAPACK as of the end of April. Revision 1: ============ Fixed a bug in sgeqpf.F. Changed default for nullity to 10. Revision 2: ========== o sgeqr2 and sgeqrf were changed to allow for m < n. As a result, processing of rejected columns has been simplified. o more accurate flop counts take ICE and computation and updating of column norms into account. o computes real and 'effective' Mflop rates. Baseline figure for QR with pivoting is the Businger/Golub algorithm. o seed for random number generator was added as an input argument Revision 3: ========== Processing of rejected columns has been changed to apply column pivoting until the estimate delivered by ICE is actually above the threshold for the condition number. This avoids rejecting 'good' columns that were thrown out as a result of the failure of the column pivoting strategy. Distributed to Karen Williamson at Rice 8/1/90. Revision 5: ========== o uses the new calling sequence for slatms o uses the third root of n to scale the maximum column norm in computing an estimate for the largest singular value. o the file structure has been changed to simply link in the lapack library from Ed Anderson's directory. Revision 8: ========== o restarts ICE at fixed intervals o consistently uses SLAUC1 to find whether a column is acceptable o From this point, Greg is doing the work. o carried out some changes to be capable to compile on the sun4 compiler. o in the unblocked code of sgeqpf.F the call to factorize columns 2:mn lacks off the the parameter MXNM, which has been added. o added two hyphens needed in the parameter checking part of sgeqpf.F. Revision 9: ========== o Removed the part about fixed columns. o All the stuff to execute inverse iteration every some steps has been removed too. o Adapted to LAPACK vesion 1.0b from LAPACK preliminary version. o Variable LWSIZE is not allowed to be smaller than KB any more. o The routine slaic1 is the one included in LAPACK version 1.0b. o The problem of "Division by zero" in the computation of the Megaflop rate when the time is zero has been solved. Revision 10: =========== o The postprocessing is executed after Chris' local pivoting algorithm, considered from now the preprocessing. o Block algorithms are used in the postprocessing. o The full algorithm is named sGEFUL. sGEQPF is still Chris' preprocessing. Revision 11: =========== o The postprocessing algorithm has been changed to improve the worst case, that is, the first type of matrix of sGNTST. o From now sGEQPF.F is the full algorithm: pre + postprocessing, sGEQPR.F is the main routine for chris' preprocessing, and sGEQPO.F is the main routine for the postprocessing. o Accounting the flops in the postprocessing has beed added. o Added the part to reveal the right rank from any estimate to the postprocessing. o The flags for the compile have been changed. Revision 12: =========== o Modified to generate single and double precision from the same code. The new command is: compile s/d machine. Revision 13: =========== o Two postprocessing algorithms have been implemented and included in this revision: Chandrasekaran&Ipsen algorithms and Pan&Tang algorithms. Distributed to Zhaoujun Bai, Kentucky. May 17, 1994. Revision 14: =========== o Chandrasekaran&Ipsen algorithms have been selected. o Adapted to the final subroutine layout for TOMS and LAPACK. o Block application of orthogonal transformations to matrix C. o The transpose of orthogonal transformations (matrix Q') are applied to matrix C from the left if job=2. o The orthogonal transformations (matrix Q) are applied to matrix C from the right if job=3. Distributed to George Fann, PNL, Spring 1995. Revision 15: ============ o Block QR (xGEQRF) is used to factorize rejected columns in the last part of QR with local pivoting. o Matrix C is completely updated with Blas-3. o Included again Pan&Tang algorithms. o Some routine names have changed: xGEQPX, xTRQPX and xTRQXC are the routines to compute Chandra&Ipsen; xGEQPY, xTRQPY and xTRQYC are the routines to compute Pan&Tang; the name xGEQPW (window pivoting) replaces to xGEQP2. o Fixed some performance and precision problems. o Prepared for submission to ACM TOMS. SHAR_EOF fi # end of overwriting check if test -f 'Sqr.in' then echo shar: will not over-write existing file "'Sqr.in'" else cat << SHAR_EOF > 'Sqr.in' 'hp' name of output file 1 how many values for m 100 values for m (on one line) 1 how many values for n 100 values for n (on one line <= 2*m) 7 how many block sizes 1 5 8 12 16 20 24 block sizes 1 number of different test matrix generators called 1 2 3 1 => xGNTST, 2 => xQRMTX, 3 => xLATMS 6 number of test cases for xGNTST 1 2 3 4 5 6 7 test cases for xGNTST (number between 1 and 7) 6 number of singular value distr. for xQRMTX 2 -2 3 -3 4 -4 +-2 => break1, +-3 => geometric, +-4 => arithmetic 6 number of singular value distr. for xLATMS 2 -2 3 -3 4 -4 +-2 => break1, +-3 => geometric, +-4 => arithmetic 3 strip width for xGNTST and xQRMTX 1 this root of epsilon is taken to multiply dep. cols. with in xQRMTX 1e-5 inverse of accept. threshold for condition number 50 gap around acceptance threshold 0.0 minimum time for a benchmark run to be valid 1381 3505 1435 3475 seed for random number generator SHAR_EOF fi # end of overwriting check if test -f 'c' then echo shar: will not over-write existing file "'c'" else cat << SHAR_EOF > 'c' compile opt d hp-iti SHAR_EOF fi # end of overwriting check if test -f 'compile' then echo shar: will not over-write existing file "'compile'" else cat << SHAR_EOF > 'compile' #!/bin/csh -f # Script to compile ls code. # # Setting user flags for preprocessing. # #set usercppflags = "-DDEBUGRANK -DERRORCHECK -DBOUNDSCHECK -DCOMPFLOPS" #set usercppflags = "-DERRORCHECK -DCHECKPOSTARGS -DBOUNDSCHECK -DCOMPFLOPS" #set usercppflags = "-DDEBUGRANK -DERRORCHECK -DBOUNDSCHECK -DCOMPFLOPS" set usercppflags = "-DERRORCHECK -DBOUNDSCHECK -DCOMPFLOPS" #set usercppflags = "-DBOUNDSCHECK -DCOMPFLOPS" #set usercppflags = "-DCOMPFLOPS" # # Start of the rest of the script. # if ($#argv < 2) goto usage set compmode = $1 set prec = $2 set version = $3 switch ("$compmode") case "opt": breaksw case "dbg": breaksw default: echo "Bad mode of compilation" goto usage endsw switch ("$version") case "hp-nuvol": switch ("$compmode") case "opt": set flags = "+O2" breaksw case "dbg": set flags = "-g -C" breaksw endsw set machine = "HP" set cpp = "/lib/cpp" set cppflags = "" set fc = "/opt/fortran/bin/f77" set fcflags = "-c -u $flags" set ld = "/opt/fortran/bin/f77" set ldflags = "+U77 $flags" set blas = "/opt/fortran/lib/pa1.1/libblas.a" set lapack = "-ltmglib-2 -llapack-2" breaksw case "hp-iti": switch ("$compmode") case "opt": set flags = "+O2" breaksw case "dbg": set flags = "-g -C" breaksw endsw set machine = "HP" set cpp = "/lib/cpp" set cppflags = "" set fc = "f77" set fcflags = "-c -u $flags" set ld = "f77" set ldflags = "+U77 $flags" set blas = "/usr/local/lib/lapack/blas.f77.a" # set blas = "/usr/local/lib/lapack/blas.hp-pa1.1.a" set lapack = "/usr/local/lib/lapack/tmglib-2.a /usr/local/lib/lapack/lapack-2.a" breaksw case "sun*": switch ("$compmode") case "opt": set flags = "-O" breaksw case "dbg": set flags = "-g -C" breaksw endsw set machine = "SUN" set cpp = "/lib/cpp" set cppflags = "" set fc = "f77" set fcflags = "-c -u $flags" set ld = "f77" set ldflags = "$flags" set blas = "/usr/local/lib/blas.a" set lapack = "/usr/local/lib/tmglib.a /usr/local/lib/lapack.a" breaksw case "solaris": switch ("$compmode") case "opt": set flags = "-O" breaksw case "dbg": set flags = "-g -C" breaksw endsw set machine = "SUN" set cpp = "/usr/ccs/lib/cpp" set cppflags = "" set fc = "f77" set fcflags = "-c -u -dalign $flags" set ld = "f77" set ldflags = "-dalign $flags" set blas = "/home1/SUNWspro/SC3.0.1/lib/libsunperf.a" set lapack = "/home1/lapack/tmglib.a" breaksw case "sgi": switch ("$compmode") case "opt": set flags = "-O" breaksw case "dbg": set flags = "-g" breaksw endsw set machine = "IRIX" set cpp = "/lib/cpp" set cppflags = "" set fc = "f77" set fcflags = "-c -64 -mips4 -nocpp $flags" set ld = "f77" set ldflags = "$flags" set blas = "" set lapack = "/usr/lib/libtmglib-2.a -lcomplib.sgimath" breaksw case "rs6000": switch ("$compmode") case "opt": set flags = "-O3" breaksw case "dbg": set flags = "-g -C" breaksw endsw set machine = "RS6K" set cpp = "/lib/cpp" set cppflags = "" set fc = "xlf" set fcflags = "-c -u $flags" set ld = "xlf" set ldflags = "$flags" set blas = "-lessl -lblas" set lapack = "/usr/local/lapack/lib/tmglib.a /usr/local/lapack/lib/lapack.a" breaksw case "alpha": switch ("$compmode") case "opt": set flags = "-O" breaksw case "dbg": set flags = "-g -C" breaksw endsw set machine = "ALPHA" set cpp = "/lib/cpp" set cppflags = "-C" set fc = "f77" set fcflags = "-c -u $flags" set ld = "f77" set ldflags = "$flags" set blas = "" set lapack = "-ldxml ../../axplib/tmglib.a ../../axplib/dsecnd.o" breaksw default: echo "Machine not recognized" goto usage endsw echo ${prec}qr_$version \ PRECISION="$prec" \ VERSION="$version" \ FC="$fc" \ FCFLAGS="$fcflags" \ LD="$ld" \ LDFLAGS="$ldflags" \ CPP="$cpp" \ CPPFLAGS="$cppflags -D$machine $usercppflags" \ LAPACK="$lapack" \ BLAS="$blas" make ${prec}qr_$version \ PRECISION="$prec" \ VERSION="$version" \ FC="$fc" \ FCFLAGS="$fcflags" \ LD="$ld" \ LDFLAGS="$ldflags" \ CPP="$cpp" \ CPPFLAGS="$cppflags -D$machine $usercppflags" \ LAPACK="$lapack" \ BLAS="$blas" exit 0 usage: echo "usage: $0 " echo " = opt or dbg" echo " = s or d" echo " = sun4, hp, rs6000 or others" exit 1 SHAR_EOF fi # end of overwriting check if test -f 'dgeqpb.f' then echo shar: will not over-write existing file "'dgeqpb.f'" else cat << SHAR_EOF > 'dgeqpb.f' SUBROUTINE DGEQPB( JOB, M, N, K, A, LDA, C, LDC, JPVT, IRCOND, $ ORCOND, RANK, SVLUES, WORK, LWORK, 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.84 $ * $Date: 96/12/30 16:59:10 $ * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, RANK, LWORK, INFO DOUBLE PRECISION IRCOND, ORCOND * .. * .. Array Arguments .. INTEGER JPVT( * ) DOUBLE PRECISION A( LDA, * ), C( LDC, * ), WORK( * ), $ SVLUES( 4 ) * .. * * Purpose * ======= * * DGEQPB 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 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. 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) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the orthogonal 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) DOUBLE PRECISION * 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) DOUBLE PRECISION * 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) DOUBLE PRECISION 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+3*N. * The block algorithm requires that: * LWORK >= 2*MN+N*NB. * If JOB<>1: * The unblocked strategy requires that: * LWORK >= 2*MN+2*N+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 xORMQR. * In both cases, the minimum required workspace is the * one for the unblocked strategy. * * INFO (output) INTEGER * = 0: Successful exit * < 0: If INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 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, DGEQPW, DGEQPC, $ DLARFT, DLARFB * .. * .. 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 workspace size. * IF( JOB.EQ.1 ) THEN WKMIN = 2*MN + 3*N ELSE WKMIN = 2*MN + 2*N + 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 ) ) THEN * * Compute the optimal workspace size. * IF( JOB.EQ.1 ) THEN NB = ILAENV( INB, 'DGEQRF', ' ', M, N, 0, 0 ) WSIZE = 2*MN + MAX( 3*N, N*NB ) ELSE NB = MAX( ILAENV( INB, 'DGEQRF', ' ', M, N, 0, 0 ), $ ILAENV( INB, 'DORMQR', ' ', M, N, 0, 0 ) ) WSIZE = MAX( 2*MN + 2*N + 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( 'DGEQPB', -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 the allowed block size for the given workspace * 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, 'DGEQRF', ' ', M, N, 0, 0 ) ).AND. $ ( MN.GE.ILAENV( IXOVER, 'DGEQRF', ' ', 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 DGEQPC( 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 ) 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 DGEQPW( M, LWSIZE, KB, KK-1, LACPTD, A, LDA, $ JPVT, RCOND, WORK( MN+1 ), SMIN, MXNM, $ WORK( 1 ), WORK( 2*MN+1 ) ) IF( LACPTD.GT.0 ) THEN * * Accumulate Householder vectors in a block reflector. * CALL DLARFT( '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 DLARFB( 'Left', '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 DLARFB( 'Left', '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 DLARFB( '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 DSWAP( 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 DGEQPC( 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 ) RANK = ACCPTD + LACPTD ELSE RANK = ACCPTD SVLUES( IAFTER ) = SMIN SVLUES( IMIN ) = SMIN END IF ELSE * * *-*-*-*-*-*-*-*-*-*-*-*-* * * using unblocked code * * *-*-*-*-*-*-*-*-*-*-*-*-* * ACCPTD = 1 CALL DGEQPC( 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 ) 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 ) = ZERO 60 CONTINUE 50 CONTINUE * WORK( 1 ) = DBLE( WSIZE ) RETURN * * End of DGEQPB * END SHAR_EOF fi # end of overwriting check if test -f 'dgeqpc.f' then echo shar: will not over-write existing file "'dgeqpc.f'" else cat << SHAR_EOF > 'dgeqpc.f' SUBROUTINE DGEQPC( JOB, M, N, K, A, LDA, C, LDC, DSRD, OFFSET, $ IRCOND, LACPTD, JPVT, TAU, X, SVLUES, MXNM, $ WORK, LWORK ) * * 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.84 $ * $Date: 96/12/30 16:59:11 $ * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, DSRD, OFFSET, LACPTD, $ LWORK DOUBLE PRECISION IRCOND, MXNM * .. * .. Array Arguments .. INTEGER JPVT( * ) DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), $ WORK( * ), X( * ), SVLUES( 4 ) * .. * * Purpose: * ======= * * DGEQPC continues a partial QR factorization of A. If * A(1:OFFSET,1:OFFSET) has been reduced to upper triangular * form, then DGEQPC 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 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. 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) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the orthogonal 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) DOUBLE PRECISION array, dimension (MIN(M,N)) * Further details of the orthogonal matrix Q (see A). * * X (input/output) DOUBLE PRECISION 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) * The estimates of the 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) DOUBLE PRECISION * 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) DOUBLE PRECISION array, dimension (LWORK) * * LWORK (input) INTEGER * MAX( 1, 3*N, N*NB ) if JOB=1, or * MAX( 1, 2*N + MAX( N, K ), MAX( N, K)*NB ) otherwise. * where NB is the maximum of blocksize used within xGEQRF and * blocksize used within xORMQR. * * 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 real scalar, and v is a real 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 ) * * 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 AII, TEMP, TEMP2, SMIN, SMINPR, SMAX, SMAXPR, $ SINE, COSINE * .. * .. External Subroutines .. EXTERNAL DLARFG, DLARF, DSWAP, DSCAL, $ DLAIC1, DORMQR, DGEQRF * .. * .. External Functions .. EXTERNAL IDAMAX, DNRM2, DLASMX, DLAUC1 INTEGER IDAMAX DOUBLE PRECISION DNRM2, DLASMX LOGICAL DLAUC1 * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. 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 WORK( I ) = DNRM2( M-OFFSET, A( OFFSET+1, I ), 1 ) WORK( N+I ) = WORK( 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, WORK( I ), 1 ) IF( PVT.NE.I ) THEN CALL DSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 ) ITEMP = JPVT( PVT ) JPVT( PVT ) = JPVT( I ) JPVT( I ) = ITEMP WORK( PVT ) = WORK( I ) WORK( N+PVT ) = WORK( N+I ) END IF * * Generate elementary reflector H(i). * IF( I.LT.M ) THEN CALL DLARFG( M-I+1, A( I, I ), A( I+1, I ), 1, $ TAU( I ) ) ELSE CALL DLARFG( 1, A( M, M ), A( M, M ), 1, TAU( M ) ) END IF * * Apply elementary reflector H(I) to the corresponding block * of matrices A and C. * AII = A( I, I ) A( I, I ) = ONE IF( I.LT.N ) THEN * * Apply H(I) to A(I:M,I+1:N) from the left. * CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, $ TAU( I ), A( I, I+1 ), LDA, WORK( 2*N+1 ) ) END IF IF( ( JOB.EQ.2 ).AND.( K.GT.0 ) ) THEN * * Apply H(I) to C(I:M,1:K) from the left. * CALL DLARF( 'Left', M-I+1, K, A( I, I ), 1, TAU( I ), $ C( I, 1 ), LDC, WORK( 2*N+1 ) ) 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 DLARF( 'Right', K, M-I+1, A( I, I ), 1, TAU( I ), $ C( 1, I ), LDC, WORK( 2*N+1 ) ) END IF A( I, I ) = AII * * Update partial column norms. * IF( I.LT.LASTI ) THEN DO 30 J = I+1, N IF( WORK( J ).NE.ZERO ) THEN TEMP = ONE-( ABS( A( I, J ) )/WORK( J ) )**2 TEMP = MAX( TEMP, ZERO ) TEMP2 = ONE+0.05*TEMP*( WORK( J )/WORK( N+J ) )**2 IF( TEMP2.EQ.ONE ) THEN WORK( J ) = DNRM2( M-I, A( I+1, J ), 1 ) WORK( N+J ) = WORK( J ) ELSE WORK( J ) = WORK( 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 ) = ONE IF( MXNM.GT.ZERO ) THEN LACPTD = 1 ELSE SVLUES( IAFTER ) = SMIN GOTO 50 END IF ELSE SMAXPR = DLASMX( I )*MXNM IF( DLAUC1( 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 DGEQRF( M-I, N-I, A( I+1, I+1 ), LDA, TAU( I+1 ), $ WORK, LWORK, INFO ) * * Apply the transformations computed in DGEQRF 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 DORMQR( 'Left', '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 DORMQR( '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 DLAIC1( 2, I-1, X, SMIN, A( 1, I ), A( I, I ), $ SMINPR, SINE, COSINE ) CALL DSCAL( 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 DGEQPC * END SHAR_EOF fi # end of overwriting check if test -f 'dgeqpw.f' then echo shar: will not over-write existing file "'dgeqpw.f'" else cat << SHAR_EOF > 'dgeqpw.f' SUBROUTINE DGEQPW( M, LWSIZE, NB, OFFSET, LACPTD, A, LDA, $ JPVT, IRCOND, X, SMIN, MXNM, TAU, WORK ) * * 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.84 $ * $Date: 96/12/30 16:59:12 $ * * .. Scalar Arguments .. INTEGER M, LWSIZE, NB, OFFSET, LACPTD, LDA DOUBLE PRECISION IRCOND, SMIN, MXNM * .. * .. Array Arguments .. INTEGER JPVT( * ) DOUBLE PRECISION A( LDA, * ), TAU( * ), X( * ), WORK( * ) * * * Purpose * ======= * * DGEQPW applies one block step of the Householder QR factorization * algorithm with restricted pivoting. It is called by DGEQPB. * * 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 DGEQP2 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 DGEQPB. * * 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) DOUBLE PRECISION 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 orthogonal * 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 orthogonal 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) DOUBLE PRECISION 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) DOUBLE PRECISION * The norm of the largest column in matrix A. * * TAU (output) DOUBLE PRECISION array, dimension (OFFSET+LWSIZE) * On exit, TAU(1:OFFSET+LACPTD) contains details of * the orthogonal matrix Q2. * * WORK (workspace) DOUBLE PRECISION array, dimension (3*LWSIZE) * * ================================================================ * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I, K, I1, LASTK, PVTIDX DOUBLE PRECISION GAMMA, AKK, TEMP, TEMP2, SMAX * .. * .. External Subroutines .. EXTERNAL DNRM2, DSCAL, DSWAP, DLARFG, $ DLARF, IDAMAX, DLAUC1, DLAPY2, $ DLASMX INTEGER IDAMAX DOUBLE PRECISION DNRM2, DLAPY2, DLASMX LOGICAL DLAUC1 * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. 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 WORK( I ) = DNRM2( M-OFFSET, A( OFFSET+1, OFFSET+I ), 1 ) WORK( LWSIZE+I ) = WORK( 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, WORK( LACPTD+1 ), 1 ) K = OFFSET + LACPTD + 1 * * Exchange current column and pivot column. * IF( PVTIDX.NE.K ) THEN CALL DSWAP( M, A( 1, PVTIDX ), 1, A( 1, K ), 1 ) I1 = JPVT( PVTIDX ) JPVT( PVTIDX ) = JPVT( K ) JPVT( K ) = I1 TEMP = WORK( PVTIDX-OFFSET ) WORK( PVTIDX-OFFSET ) = WORK( K-OFFSET ) WORK( K-OFFSET ) = TEMP TEMP = WORK( PVTIDX-OFFSET+LWSIZE ) WORK( PVTIDX-OFFSET+LWSIZE ) = WORK( K+LWSIZE-OFFSET ) WORK( K+LWSIZE-OFFSET ) = TEMP END IF * * Determine (offset+lacptd+1)st diagonal element GAMMA of * matrix A if elementary reflector were applied. * IF( A( K, K ).EQ.ZERO ) THEN GAMMA = -WORK( K-OFFSET ) ELSE GAMMA = -SIGN( WORK( K-OFFSET ), A( K, K ) ) END IF * * Update estimate for largest singular value. * SMAX = DLASMX( K )*MXNM * * Is candidate pivot column acceptable ? * ===================================== * IF( DLAUC1( 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 DLARFG( M-K+1, A( K, K ), A( K+1, K ), 1, $ TAU( K ) ) ELSE CALL DLARFG( 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 ) = ONE CALL DLARF( 'Left', M-K+1, LWSIZE-LACPTD, $ A( K, K ), 1, TAU( K ), A( K, K+1 ), LDA, $ WORK( 2*LWSIZE+1 ) ) A( K, K ) = AKK END IF * * Update partial column norms. * IF( K.LT.LASTK ) THEN DO 20 I = LACPTD+1,LWSIZE IF( WORK( I ).NE.ZERO ) THEN TEMP = ONE-( ABS( A( K, OFFSET+I ) )/WORK( I ) )**2 TEMP = MAX( TEMP, ZERO ) TEMP2 = ONE+ $ 0.05*TEMP*( WORK( I )/WORK( I+LWSIZE ) )**2 IF( TEMP2.EQ.ONE ) THEN WORK( I ) = $ DNRM2( M-K, A( K+1, OFFSET+I ), 1 ) WORK( I+LWSIZE ) = WORK( I ) ELSE WORK( I ) = WORK( 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 DGEQPW * END SHAR_EOF fi # end of overwriting check if test -f 'dgeqpx.f' then echo shar: will not over-write existing file "'dgeqpx.f'" else cat << SHAR_EOF > 'dgeqpx.f' SUBROUTINE DGEQPX( JOB, M, N, K, A, LDA, C, LDC, JPVT, IRCOND, $ ORCOND, RANK, SVLUES, WORK, LWORK, 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.84 $ * $Date: 96/12/30 16:59:13 $ * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, RANK, LWORK, INFO DOUBLE PRECISION IRCOND, ORCOND * .. * .. Array Arguments .. INTEGER JPVT( * ) DOUBLE PRECISION A( LDA, * ), C( LDC, * ), $ WORK( * ), SVLUES( 4 ) * .. * * Purpose * ======= * * DGEQPX 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 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. 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) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the orthogonal 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) DOUBLE PRECISION * 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) DOUBLE PRECISION * 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) 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) DOUBLE PRECISION 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+3*N. * The block algorithm requires that: * LWORK >= 2*MN+N*NB. * If JOB<>1: * The unblocked strategy requires that: * LWORK >= 2*MN+2*N+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. * * 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, DGEQPB, DTRQPX * .. * .. Intrinsic Functions .. INTRINSIC MIN, MAX * .. * .. Local Scalars .. DOUBLE PRECISION WSIZE INTEGER MN, WKMIN * .. * .. Executable Statements .. * MN = MIN( M, N ) IF( JOB.EQ.1 ) THEN WKMIN = 2*MN+3*N ELSE WKMIN = 2*MN+2*N+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( 'DGEQPX',-INFO ) RETURN END IF * * Preprocessing * ============= * CALL DGEQPB( JOB, M, N, K, A, LDA, C, LDC, JPVT, IRCOND, $ ORCOND, RANK, SVLUES, WORK, LWORK, INFO ) WSIZE = WORK( 1 ) * * Postprocessing * ============== * IF( RANK.GT.0 ) THEN CALL DTRQPX( JOB, M, N, K, A, LDA, C, LDC, JPVT, IRCOND, $ ORCOND, RANK, SVLUES, WORK, LWORK, INFO ) END IF * WORK( 1 ) = WSIZE RETURN * * End of DGEQPX * END SHAR_EOF fi # end of overwriting check if test -f 'dgeqpy.f' then echo shar: will not over-write existing file "'dgeqpy.f'" else cat << SHAR_EOF > 'dgeqpy.f' SUBROUTINE DGEQPY( JOB, M, N, K, A, LDA, C, LDC, JPVT, IRCOND, $ ORCOND, RANK, SVLUES, WORK, LWORK, 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.84 $ * $Date: 96/12/30 16:59:14 $ * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, RANK, LWORK, INFO DOUBLE PRECISION IRCOND, ORCOND * .. * .. Array Arguments .. INTEGER JPVT( * ) DOUBLE PRECISION A( LDA, * ), C( LDC, * ), $ WORK( * ), SVLUES( 4 ) * .. * * Purpose * ======= * * DGEQPY 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 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. 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) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the orthogonal 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) DOUBLE PRECISION * 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) DOUBLE PRECISION * 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) 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) DOUBLE PRECISION 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+3*N. * The block algorithm requires that: * LWORK >= 2*MN+N*NB. * If JOB<>1: * The unblocked strategy requires that: * LWORK >= 2*MN+2*N+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. * * 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, DGEQPB, DTRQPY * .. * .. Intrinsic Functions .. INTRINSIC MIN, MAX * .. * .. Local Scalars .. DOUBLE PRECISION WSIZE INTEGER MN, WKMIN * .. * .. Executable Statements .. * MN = MIN( M, N ) IF( JOB.EQ.1 ) THEN WKMIN = 2*MN+3*N ELSE WKMIN = 2*MN+2*N+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( 'DGEQPY',-INFO ) RETURN END IF * * Preprocessing * ============= * CALL DGEQPB( JOB, M, N, K, A, LDA, C, LDC, JPVT, IRCOND, $ ORCOND, RANK, SVLUES, WORK, LWORK, INFO ) WSIZE = WORK( 1 ) * * Postprocessing * ============== * IF( RANK.GT.0 ) THEN CALL DTRQPY( JOB, M, N, K, A, LDA, C, LDC, JPVT, IRCOND, $ ORCOND, RANK, SVLUES, WORK, LWORK, INFO ) END IF * WORK( 1 ) = WSIZE RETURN * * End of DGEQPY * END SHAR_EOF fi # end of overwriting check if test -f 'dgntst.f' then echo shar: will not over-write existing file "'dgntst.f'" else cat << SHAR_EOF > 'dgntst.f' SUBROUTINE DGNTST( WHICH, M, N, RTHRESH, GAP, STRIP, ISEED, $ RANK, S, A, LDA, WORK ) * * 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.84 $ * $Date: 96/12/30 16:59:14 $ * * .. Scalar Arguments .. INTEGER WHICH, M, N, STRIP, RANK, LDA DOUBLE PRECISION RTHRESH, GAP * .. * .. Array Arguments .. INTEGER ISEED( 4 ) DOUBLE PRECISION A( LDA, * ), S( * ), WORK( * ) * .. * * Purpose: * ======= * * DGNTST forms a test matrix for DGEQPF, the QR factorization with * restricted column pivoting. * * Arguments: * ========= * * WHICH (input) INTEGER * Determines what kind of matrix is generated. Setting * MN = min(M,N), we have for WHICH = * 1: The last MN/2 columns are generated with MN/2-1 * singular values equal 1 and one equal to RTHRESH/GAP. * The remaining columns are random linear combinations of * those MN/2 columns, scaled by sqrt(sqrt(eps)). * Argument STRIP is not referenced. * 2: columns 2:MN are generated with singular values between * 1 and GAP*RTHRESH in arithmetic progression. Column 1 is * a random multiple of column2. Columns MN+1:N are random * linear combinations of previous columns, scaled by * sqrt(sqrt(eps)). * Argument STRIP is not referenced. * 3: Generates an m-by-n matrix with singular values between * 1 and GAP*RTHRESH in geometric sequence. * Argument STRIP is not referenced. * 4: Generates a matrix which has STRIP * columns with norms in the order of sqrt(sqrt(eps)) * up front. The rest of the columns is generated with a * geometric distribution of singular values between 1 and * GAP*RTHRESH. * 5: Generates a matrix which has STRIP * columns with an arithmetic distribution of singular * values between 1 and GAP*RTHRESH up front. The remaining * columns are random linear combinations of these columns * with permutations of the order of sqrt(epsilon). * 6: Matrix with random singular values between 1 and * RTHRESH*GAP, except for six small singular values, which * are all small around RTHRESH*GAP. * any other value or when the matrix sizes are too small for * a selected option to make sense: * generate null matrix. * * M (input) INTEGER * The number or rows of the matrix. * * N (input) INTEGER * The number of columns of the matrix A. * * RTHRESH (input) DOUBLE PRECISION * 1/RTHRESH is the acceptance threshold for the condition * number of a matrix. * * GAP (input) DOUBLE PRECISION * GAP (.gt. ONE) determines singular values around threshold. * The smallest singular value above RTHRESH will be * GAP*RTHRESH, the next singular value below RTHRESH * will be RTHRESH/GAP. * * STRIP (input) INTEGER * The width of dependent strips. * * ISEED (input/output) INTEGER array, dimension (4) * seed for the random number generator. ISEED(4) must be odd. * * RANK (output) INTEGER * The rank of the matrix generated with respect to the * threshold 1/RTHRESH. * * S (output) DOUBLE PRECISION array, dimension min(M,N) * singular values of A * * A (output) DOUBLE PRECISION array, dimension (LDA,N) * The m-by-n matrix being generated * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= M. * * WORK (workspace) DOUBLE PRECISION array, * dimension M*N+3*max(M,min(M,N))+max(M,N) * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * * input arguments for SLATMS: * BREAK: all sing. values 1 except for last one * ARITH: arithmetic sequence * GEOM: geometric sequence * INTEGER BREAK, ARITH, GEOM PARAMETER ( BREAK = 2, GEOM = 3, ARITH = 4 ) * .. * .. Local Scalars .. INTEGER MN, WIDTH1, WIDTH2, INFO, I, J DOUBLE PRECISION DUMMY, RTEPS, EPS, TEMP * .. * .. External Subroutines .. EXTERNAL DGEMM, DCOPY, DSCAL, DLARNV, $ DGEBD2, DBDSQR * .. * .. External Functions .. EXTERNAL DLARAN, SFRANK, DNRM2, DLAMCH INTEGER SFRANK DOUBLE PRECISION DLARAN, DLAMCH, DNRM2 * .. * .. Intrinsic Functions .. INTRINSIC MIN, MAX, MOD, SQRT, DBLE * .. * .. Executable Statements .. * MN = MIN( M, N ) EPS = DLAMCH( 'Epsilon' ) RTEPS = SQRT( SQRT( EPS ) ) * IF( WHICH.EQ.1 ) THEN * * columns MN/2+1:MN of A are linearly dependent with condition * number GAP/RTHRESH. * IF( MN.LE.1 ) GOTO 1111 IF( MOD( MN, 2 ).EQ.0 ) THEN WIDTH1 = MN/2 WIDTH2 = MN/2 ELSE WIDTH1 = ( MN-1 )/2 WIDTH2 = ( MN+1 )/2 END IF * * generate A(:,1+WIDTH1:MN) such that all singular values * are 1 except for last one which is RTHRESH/GAP * CALL DLATMS( M, WIDTH2, 'Uniform Distribution', ISEED, $ 'Nonsymmetric', S, -BREAK, GAP/RTHRESH, ONE, M, $ WIDTH2, 'No Packing', A( 1, WIDTH1+1 ), LDA, $ WORK, INFO ) * * multiply A(:,1+WIDTH1:MN) with a random * WIDTH2-by-WIDTH1 matrix to generate A(1,1:WIDTH1). * IF( WIDTH1.GT.0 ) THEN CALL DLARNV(1,ISEED,WIDTH1*WIDTH2,WORK(1)) CALL DGEMM( 'no transpose', 'no transpose', M, WIDTH1, $ WIDTH2, RTEPS, A( 1, WIDTH1+1 ), LDA, WORK, $ WIDTH2, ZERO, A( 1, 1 ), LDA ) END IF * * multiply A(:,1+WIDTH1:MN) with a random * WIDTH2-by-(N-MN) matrix to generate A(:,MN+1:N). * IF( MN.LT.N ) THEN CALL DLARNV(1,ISEED,WIDTH2*(N-MN),WORK(1)) CALL DGEMM( 'no transpose', 'no transpose', M, N-MN, $ WIDTH2, RTEPS, A( 1, WIDTH1+1 ), LDA, WORK, $ WIDTH2, ZERO, A( 1, MN+1 ), LDA ) END IF * * compute SVD of A * CALL DLACPY( 'full', M, N, A, LDA, WORK( MN+1 ), M ) CALL DGEBD2( M, N, WORK( MN+1 ), M, S, WORK( 1 ), $ WORK( MN+M*N+1 ),WORK( 2*MN+M*N+1 ), $ WORK( 3*MN+M*N+1 ),INFO ) CALL DBDSQR( 'upper', MN, 0, 0, 0, S, WORK(1), $ DUMMY, MN, DUMMY, 1, DUMMY, MN, WORK( MN+1 ), INFO ) * * initialize RANK * RANK = SFRANK( S, MN, RTHRESH ) RETURN ELSEIF( WHICH.EQ.2 ) THEN * * columns 2:MN are linearly independent. column 1 is dependent. * The singular values of A are similar to an arithmetic sequence * from 1 to GAP*RTHRESH. * * generate A(:,2:MN) such that singular values decline in * arithmetic progression from 1 to GAP*RTHRESH. * IF( MN.LT.2 ) GOTO 1111 CALL DLATMS( M, MN-1, 'Uniform Distribution', ISEED, $ 'Nonsymmetric', S, -ARITH, ONE/(GAP*RTHRESH), ONE, $ M,MN-1, 'No Packing', A( 1, 2 ), LDA, WORK, INFO ) * * first column is random multiple of second column * CALL DCOPY( M, A( 1, 2 ), 1, A( 1, 1 ), 1 ) CALL DSCAL( M, DLARAN( ISEED ), A( 1, 1 ), 1 ) * * multiply A(:,2:MN) with a random * (MN-1)-by-(N-MN) matrix to generate A(:,MN+1:N). * IF( MN.LT.N ) THEN CALL DLARNV( 1, ISEED, (MN-1)*(N-MN), WORK( 1 ) ) CALL DGEMM( 'no transpose' , 'no transpose', M, N-MN, $ MN-1, RTEPS, A( 1, 2 ), LDA, WORK, MN-1, ZERO, $ A( 1, MN+1 ), LDA ) END IF * * compute SVD of A * CALL DLACPY( 'full matrix', M, N, A, LDA, WORK( MN+1 ), M ) CALL DGEBD2( M, N, WORK( MN+1 ), M, S, WORK( 1 ), $ WORK( MN+M*N+1 ),WORK( 2*MN+M*N+1 ), $ WORK( 3*MN+M*N+1 ),INFO ) CALL DBDSQR( 'upper',MN, 0, 0, 0, S, WORK( 1 ), $ DUMMY, MN, DUMMY, 1, DUMMY, MN, WORK( MN+1 ), INFO ) * * initialize RANK * RANK = SFRANK( S, MN, RTHRESH ) RETURN ELSEIF( WHICH.EQ.3 ) THEN * * generate a matrix with full rank and fix the first (MN-1) * columns. The singular values are generated with a geometric * distribution. * CALL DLATMS( M, N, 'Uniform', ISEED, 'Nonsymmetric', S, $ GEOM, ONE/(GAP*RTHRESH), ONE, M, N, 'No Packing', $ A, LDA, WORK, INFO ) RANK = MN RETURN ELSEIF( WHICH.EQ.4 ) THEN * * generate a matrix which has min(STRIP,N-1) small columns up front, * the rest of the columns is independent and generated with * a geometric distribution of singular values. * WIDTH1 = MAX( 1, MIN( STRIP, N-1 ) ) DO 80 J = 1, WIDTH1 CALL DLARNV( 1, ISEED, M, A( 1, J ) ) **** CALL SSCAL(M,RTEPS,A(1,J),1) 80 CONTINUE IF( N.EQ.1 ) THEN S( 1 ) = DNRM2( M, A( 1, 1 ),1 ) RANK = 0 RETURN ELSEIF( M.EQ.1 ) THEN IF( N.GT.1 ) THEN DO 85 I = 2, N A( 1, I ) = ONE 85 CONTINUE S( 1 ) = DNRM2( N, A( 1, 1 ), LDA ) RANK = 1 ELSE S( 1 ) = ABS( A( 1, 1 ) ) RANK = 0 END IF RETURN END IF CALL DLATMS( M, N-WIDTH1, 'Uniform', ISEED, 'Nonsymmetric', $ S, GEOM, ONE/( GAP*RTHRESH ), ONE, M, N-WIDTH1, $ 'No Packing', A( 1, WIDTH1+1 ), LDA, WORK, INFO ) * * compute SVD * CALL DLACPY( 'full matrix', M, N, A, LDA, WORK( MN+1 ), M ) CALL DGEBD2( M, N, WORK( MN+1 ), M, S, WORK( 1 ), $ WORK( MN+M*N+1 ),WORK( 2*MN+M*N+1 ), $ WORK( 3*MN+M*N+1 ), INFO ) CALL DBDSQR( 'upper', MN, 0, 0, 0, S, WORK( 1 ), $ DUMMY, MN, DUMMY, 1, DUMMY, MN, WORK( MN+1 ), INFO ) RANK = SFRANK( S, MN, RTHRESH ) RETURN ELSEIF( WHICH.EQ.5 ) THEN * * generate a matrix which has STRIP independent columns up front, * using an arithmetic sequence of singular values. * The rest of the columns is generated as linear combinations of * the previous ones with a perturbation of order epsilon. * WIDTH1 = MIN( STRIP, MN ) CALL DLATMS( M, WIDTH1, 'Uniform', ISEED, 'Nonsymmetric', $ S, ARITH, ONE/( GAP*RTHRESH ), ONE, M, WIDTH1, $ 'No Packing', A, LDA, WORK, INFO ) IF( N.GT.WIDTH1 ) THEN CALL DLARNV( 1, ISEED, WIDTH1*( N-WIDTH1 ), WORK( 1 ) ) DO 110 J = WIDTH1+1, N CALL DLARNV( 1, ISEED, M, A( 1, J ) ) 110 CONTINUE CALL DGEMM( 'no transpose', 'no transpose', M, N-WIDTH1, $ WIDTH1, RTEPS, A( 1, 1 ), LDA, WORK, WIDTH1, EPS, $ A( 1, WIDTH1+1 ), LDA ) END IF * * compute SVD of A * CALL DLACPY( 'full matrix', M, N, A, LDA, WORK( MN+1 ), M ) CALL DGEBD2( M, N, WORK( MN+1 ), M, S, WORK( 1 ), $ WORK( MN+M*N+1 ), WORK( 2*MN+M*N+1 ), $ WORK( 3*MN+M*N+1 ), INFO ) CALL DBDSQR( 'upper', MN, 0, 0, 0, S, WORK( 1 ), $ DUMMY, MN, DUMMY, 1, DUMMY, MN, WORK( MN+1 ), INFO ) RANK = SFRANK( S, MN, RTHRESH ) RETURN ELSEIF( WHICH.EQ.6 ) THEN * * Peter's suggestion: Matrix with random singular values, * between 1 and RTHRESH*GAP, and six very close singular * values around RTHRESH*GAP. * S( 1 ) = ONE DO 160 I = 2, MN-6 170 TEMP = DLARAN( ISEED ) IF( TEMP.GE.RTHRESH*GAP ) THEN S( I ) = TEMP ELSE GOTO 170 END IF 160 CONTINUE DO 180 I = MAX( 2, MN-5 ), MN S( I ) = RTHRESH*GAP*( ONE+3.0*DLARAN( ISEED ) ) 180 CONTINUE CALL DLATMS( M, N, 'Uniform', ISEED, 'Nonsymmetric', S, 0, $ DUMMY, ONE, M, N, 'No Packing', A, LDA, WORK, INFO ) CALL DSORT( MN, S, 1, 'decreasing' ) RANK = MN RETURN ELSEIF( WHICH.EQ.7 ) THEN * * Generate Null matrix * DO 130 J = 1, N DO 140 I = 1, M A( I, J ) = ZERO 140 CONTINUE 130 CONTINUE DO 150 I = 1, MN S( I ) = ZERO 150 CONTINUE RANK = 0 RETURN END IF 1111 CONTINUE * * Default: Generate matrix of all ones * DO 190 J = 1,N DO 200 I = 1, M A( I, J ) = ONE 200 CONTINUE 190 CONTINUE S( 1 ) = SQRT( DBLE( M*N ) ) DO 210 I = 2, MN S( I ) = ZERO 210 CONTINUE RANK = 1 RETURN * * End of DGNTST * END SHAR_EOF fi # end of overwriting check if test -f 'dlasmx.f' then echo shar: will not over-write existing file "'dlasmx.f'" else cat << SHAR_EOF > 'dlasmx.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 'dlauc1.f' then echo shar: will not over-write existing file "'dlauc1.f'" else cat << SHAR_EOF > 'dlauc1.f' LOGICAL FUNCTION DLAUC1( 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.84 $ * $Date: 96/12/30 16:59:16 $ * * .. Scalar Arguments .. INTEGER K DOUBLE PRECISION SMIN, GAMMA, THRESH * .. * .. Array Arguments .. DOUBLE PRECISION W( * ), X( * ) * .. * * Purpose * ======= * * DLAUC1 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) DOUBLE PRECISION 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 DLAUC1 == .TRUE., X contains an approximate * smallest left singular vector of the upper triangle of * A(1:k,1:k); if DLAUC1 == .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 DLAUC1 == .TRUE., SMIN is an estimate of the * smallest singular value of the upper triangle of A(1:k,1:k); * if DLAUC1 == .FALSE., SMIN is unchanged. * * W (input) DOUBLE PRECISION array, dimension ( K-1 ) * The K-th column of matrix A excluding the diagonal element. * * GAMMA (input) DOUBLE PRECISION * 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. * * (DLAUC1) (output) LOGICAL * If the k-th column of A is found acceptable, DLAUC1 * returns .TRUE., otherwise it returns .FALSE. * * ===================================================================== * * .. Local Scalars .. DOUBLE PRECISION SMINPR, SINE, COSINE * .. * .. External Subroutines .. EXTERNAL DLAIC1, DSCAL * .. * .. Intrinsic Functions .. INTRINSIC ABS * * .. * .. Executable Statements .. * * * Try to use diagonal element as condition estimator * IF( THRESH.GT.ABS( GAMMA ) ) THEN DLAUC1 = .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 DLAIC1( 2, K-1, X, SMIN, W, GAMMA, SMINPR, $ SINE, COSINE ) IF( THRESH.GT.SMINPR ) THEN DLAUC1 = .FALSE. ELSE CALL DSCAL( K-1, SINE, X, 1 ) X( K ) = COSINE SMIN = SMINPR DLAUC1 = .TRUE. END IF RETURN * * End of DLAUC1 * END SHAR_EOF fi # end of overwriting check if test -f 'dmylap.f' then echo shar: will not over-write existing file "'dmylap.f'" else cat << SHAR_EOF > 'dmylap.f' ********************************************************************* SUBROUTINE DGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO ) * * -- LAPACK test 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 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * DGEQPF computes a QR factorization with column pivoting of a * real 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) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (min(M,N)) * Stores further details of * the orthogonal matrix Q (see A). * * WORK (workspace) DOUBLE PRECISION array, dimension (3*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 real scalar, and v is a real 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 AII, TEMP, TEMP2 * .. * .. External Subroutines .. EXTERNAL DGEQR2, DLARF, DLARFG, DORM2R, DSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DNRM2 EXTERNAL IDAMAX, 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( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEQPF', -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 DSWAP( 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 DGEQR2( M, MA, A, LDA, TAU, WORK, INFO ) IF( MA.LT.N ) THEN CALL DORM2R( 'Left', '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 WORK( I ) = DNRM2( M-ITEMP, A( ITEMP+1, I ), 1 ) WORK( N+I ) = WORK( 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, WORK( I ), 1 ) * IF( PVT.NE.I ) THEN CALL DSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 ) ITEMP = JPVT( PVT ) JPVT( PVT ) = JPVT( I ) JPVT( I ) = ITEMP WORK( PVT ) = WORK( I ) WORK( N+PVT ) = WORK( N+I ) END IF * * Generate elementary reflector H(i) * IF( I.LT.M ) THEN CALL DLARFG( M-I+1, A( I, I ), A( I+1, I ), 1, TAU( I ) ) ELSE CALL DLARFG( 1, A( M, M ), A( M, M ), 1, TAU( M ) ) END IF * 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 ) = ONE CALL DLARF( 'LEFT', M-I+1, N-I, A( I, I ), 1, TAU( I ), $ A( I, I+1 ), LDA, WORK( 2*N+1 ) ) A( I, I ) = AII END IF * * Update partial column norms * DO 30 J = I + 1, N IF( WORK( J ).NE.ZERO ) THEN TEMP = ONE - ( ABS( A( I, J ) ) / WORK( J ) )**2 TEMP = MAX( TEMP, ZERO ) TEMP2 = ONE + 0.05D0*TEMP* $ ( WORK( J ) / WORK( N+J ) )**2 IF( TEMP2.EQ.ONE ) THEN IF( M-I.GT.0 ) THEN WORK( J ) = DNRM2( M-I, A( I+1, J ), 1 ) WORK( N+J ) = WORK( J ) ELSE WORK( J ) = ZERO WORK( N+J ) = ZERO END IF ELSE WORK( J ) = WORK( J )*SQRT( TEMP ) END IF END IF 30 CONTINUE * 40 CONTINUE END IF RETURN * * End of DGEQPF * END ********************************************************************* SUBROUTINE DGEQRF( 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 .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( LWORK ) * .. * * Purpose * ======= * * DGEQRF computes a QR factorization of a real 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) DOUBLE PRECISION 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 orthogonal 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) DOUBLE PRECISION array, dimension (min(M,N)) * The scalar factors of the elementary reflectors (see Further * Details). * * WORK (workspace) DOUBLE PRECISION 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 real scalar, and v is a real 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 DGEQR2, DLARFB, DLARFT, 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( 'DGEQRF', -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, 'DGEQRF', ' ', 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, 'DGEQRF', ' ', 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, 'DGEQRF', ' ', 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 DGEQR2( 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 DLARFT( '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 DLARFB( 'Left', '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 DGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, $ IINFO ) * WORK( 1 ) = IWS RETURN * * End of DGEQRF * END ********************************************************************* SUBROUTINE DGEQR2( 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 .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * DGEQR2 computes a QR factorization of a real 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) DOUBLE PRECISION 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 orthogonal 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) DOUBLE PRECISION array, dimension (min(M,N)) * The scalar factors of the elementary reflectors (see Further * Details). * * WORK (workspace) DOUBLE PRECISION 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 real scalar, and v is a real 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 .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I, K DOUBLE PRECISION AII * .. * .. External Subroutines .. EXTERNAL DLARF, DLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC 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( 'DGEQR2', -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 DLARFG( 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 * AII = A( I, I ) A( I, I ) = ONE CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), $ A( I, I+1 ), LDA, WORK ) A( I, I ) = AII END IF 10 CONTINUE RETURN * * End of DGEQR2 * END ********************************************************************* SHAR_EOF fi # end of overwriting check if test -f 'dqr.f' then echo shar: will not over-write existing file "'dqr.f'" else cat << SHAR_EOF > 'dqr.f' PROGRAM Dqr * * Test and timing program for the Rank-Revealing QR factorization. * * 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.84 $ * $Date: 96/12/30 16:59:17 $ * * Constants: * ========= * DOUBLE PRECISION ZERO, ONE, HUNDRED, MILLION PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, $ HUNDRED = 1.0D+2, MILLION = 1.0D+6 ) INTEGER MMAX, NMAX, MAXTEST, NBMAX, uin, uoutrl, uoutfl PARAMETER ( MMAX=1001, NMAX=MMAX, NBMAX=64, MAXTEST=9, $ uin=15, uoutrl=16, uoutfl=17 ) * * Make sure that MAXTEST<=9; otherwise some format statememts bomb. CHARACTER*6 infile PARAMETER (infile = 'Dqr.in') * lda, nmax test matrix array is lda -by- nmax * MAXTEST maximal number of test values for any PARAMETER * is assumed to be less than 10 !!! * NBMAX maximal blocksize * uin/uout unit number for input/output file * infile name of input file integer flppre, flpice, flppst common /CNTFLP/ flppre, flpice, flppst * flppre variable used to accumulate the number of flops * performed in the preprocessing * flppst variable used to accumulate the number of flops * performed in the postprocessing * flpice variable used to accumulate the number of flops * performed in ICE, both in pre and postprocessing INTEGER PERFMSR, TIME, FLOPS, MFLOPS, NORUNS, STFLPS, $ RLFLPS, STMFLP, RLMFLP, TRANK, TRCOND, $ ICFLPS, POFLPS PARAMETER ( PERFMSR = 10, TIME = 1, STFLPS = 2, $ STMFLP = 3, RLFLPS = 4, RLMFLP = 5, NORUNS=6, $ FLOPS = 2, MFLOPS = 3, TRANK = 7, TRCOND = 8, $ ICFLPS = 9, POFLPS = 10 ) * PERFMSR number of performance measures taken * TIME total execution time in seconds * STFLPS the no. of flops required by the standard algorithm * (xGEQR2: non-block QR factorization with no pivoting) * STMFLP execution rate defined by STFLPS * RLFLPS the number of floating point operations actually * performed. * RLMFLP execution rate defined by RLFLPS. * NORUNS total number of runs executed * FLOPS the same as STMFLP for the classical algorithms * where STFLPS = RLFLPS * MFLOPS the execution rate induced by FLOPS * TRANK rank as returned by QR routine * TRCOND inverse of estimated condition number INTEGER RELMSR, ACCEPTED, ESTRK, IRCOND, DRCOND, $ ISMAX,DSMAX, ISBEFOR, DSBEFOR, $ ISAFTER, DSAFTER, ISMIN, DSMIN PARAMETER ( RELMSR = 12, $ ACCEPTED = 1, ESTRK = 2, $ IRCOND = 3, DRCOND = 4, $ ISMAX = 5, DSMAX = 6, $ ISBEFOR = 7, DSBEFOR = 8, $ ISAFTER = 9, DSAFTER = 10, $ ISMIN = 11, DSMIN = 12 ) * Let R1 = R(1:accepted,1:accepted), * R2 = R(1:r,1:r), where r = min(mn,accepted+1) * * RELMSR number of reliability data sampled * ACCEPTED number of columns that was accepted * ESTRK estimated rank (input to xGEQPX and xGEQPY) * IRCOND inverse of condition number of R1 * DRCOND the factor rcond_hat/rcond * ISMAX largest singular value of R1 * DSMAX the factor smax/smax_hat * ISBEFOR smallest singular value of R1 * DSBEFOR the factor sbefor_hat/sbefor * ISAFTER smallest singular value of R2 * DSAFTER the factor safter_hat/safter * ISMIN the smallest singular value of R * DSMIN the factor smin_hat/smin * * Indices into the 'svlues' array returned by xGEQPX and xGEQPY * * * Indices into the 'svlues' array. * INTEGER IMAX, IBEFOR, IAFTER, IMIN PARAMETER ( IMAX = 1, IBEFOR = 2, IAFTER = 3, IMIN = 4 ) * .. INTEGER LINRTS, BL1, BL2 PARAMETER ( LINRTS = 2, BL1 = 1, BL2 = 2 ) CHARACTER*6 LINNAMES(LINRTS) * LINRTS number of versions of LINPACK QR routine with column * pivoting * BL1 blas 1 version * BL2 blas 2 version * LINNAMES LINNAMES(i) is the name of routine i, i in {BL1,BL2} INTEGER TOPTMAX, GNTST, QRMTX, LATMS PARAMETER ( TOPTMAX = 3, GNTST = 1, QRMTX = 2, $ LATMS = 3 ) CHARACTER*6 ctopt( TOPTMAX ) * TOPTMAX number of test matrix generators * GNTST testing special cases * QRMTX routine xQRMTX generating strips of dependent and * independent columns * LATMS routine xLATMS -- LAPACK test matrix generator * ctopt ctopt(i) is the name or routine i, * i in {GNTST,QRMTX,LATMS} INTEGER MODEMAX, FIX1, FIX2, FULLRK, SMFRNT, SMBACK, $ NLLMTX, PETER, BREAK1, GEOM, ARITH PARAMETER ( MODEMAX = 7, FIX1 = 1, FIX2 = 2, FULLRK = 3, $ SMFRNT = 4, SMBACK = 5, PETER = 6, NLLMTX = 7, $ BREAK1 = 2, GEOM = 3, ARITH = 4 ) CHARACTER*40 cmode( TOPTMAX, -MODEMAX:MODEMAX ) * MODEMAX maximal number of different distributions that can * be generated by any of the test matrix generators. * MAKE SURE that MODEMAX >= 2*(# of options for * distributions DLATMS) * otherwise arrays for holding 'mode' are too short. * * options for xGNTST: * FIX1 matrix w/ rank MN/2-1 * FIX2 cols 2:MN full rank, rest dep. * FULLRK full rank * SMFRNT STRIP small cols up front, rest indep. * SMBACK STRIP indep. cols up front, rest dep. * PETER Peter Tang's distribution: a few small singular * values that are very close together. * NLLMTX null matrix * * options for xQRMTX and XLATMS: * BREAK1 break1 distribution * GEOM geometric distribution * ARITH arithmetic distribution * * cmode cmode(topt,i) is a description of the matrix that * is generated by routine referred to as topt with * argument 'mode' set to 'i'. * * INTRINSICS: * =========== * INTRINSIC DBLE, MAX, MIN * * ******************************** * * Variables read by input file * * ******************************** CHARACTER*40 outfile INTEGER m, nm, am(MAXTEST), im, $ n, nn, an(MAXTEST), in, $ nb, nnb, anb(MAXTEST),inb, $ topt,ntopt,atopt(TOPTMAX),itopt, $ nmod1,amod1(MODEMAX), $ nmod2,amod2(MODEMAX), $ nmod3,amod3(MODEMAX), $ mode,nmode,amode(MODEMAX),imode, $ strip, iseed(4), job, k DOUBLE PRECISION irthresh, orthresh, gap, timmin, scale * outfile name of output file * m number of rows of test matrix (m.LE.MMAX) * n number of columns of test matrix (n.LE.NMAX) * n bblock size (nb. le. NBMAX) * topt different test matrix generators to be CALLed * =1: CALL DGNTST * =2: CALL DQRMTX * =3: CALL DLATMS * mod1 distributions to generate for xGNTST * mod2 distributions to generate for xQRMTX * mod3 distributions to generate for xLATMS * mode distributions to generate for matrix generator * actually chosen. * dfct different ways of choosing estimated rank of A. * For each of in {m,n,nb,topt,mod1,mod2,mod3,mode,dfct}, * n is the number of values for test for , a is * an array holding these test values, and i is the loop * variable for the loop stepping through a. * strip choice of strip width for xGNTST and xQRMTX * scale epsilon**scale is taken to multiply dependent * columns in xQRMTX. * irthresh (input) inverse of threshold for condition number of a * matrix * orthresh (output) inverse of threshold for condition number of a * matrix * gap gap around threshold for generating dependent or * full rank matrices * timmin minimum time for a benchmark run * iseed array to initialize the random number generator * iseed(4) must be odd * * ******************** * * Other variables: * * ******************** * * SCALARS * ======= * INTEGER mn, lda, i, j, nobefore, rank, $ runs, ls, info, oiseed(4) DOUBLE PRECISION eps, bstrcond, t1, t2, trt, $ smax, smin, smaxpr, sminpr, mnrm, mnrmpr, $ realsmin, temp CHARACTER*1 c1 CHARACTER*80 fmt * * mn shorthand for min(m,n) * lda leading dimension of A * nobefore the rank of A with respect to the threshold rcond. * rank on output the rank determined by xGEQPB, xGEQPX and xGEQPY. * runs number of runs needed to accumulate timmin seconds * iseed seed for xLATMS * bstrcond equal to s(nobefore)/s(1) * ls length of work array for xGEQPB, xGEQPX and xGEQPY * info return PARAMETER of LAPACK routines * eps machine precision * trt total run time * smax estimate for largest singular value * smin estimate for smallest singular value * * FOR PERFORMANCE MEASUREMENT * =========================== DOUBLE PRECISION ttime, tircond, tdrcond, tismax, $ tdsmax, tisbefor, tdsbefor, tisafter, $ tdsafter, tismin, tdsmin INTEGER taccptd DOUBLE PRECISION lint(LINRTS,PERFMSR), $ cwytnop(MAXTEST,PERFMSR), $ cwytqpb(MAXTEST,PERFMSR), $ cwytqpx(MAXTEST,PERFMSR), $ cwytqpy(MAXTEST,PERFMSR) * lint performance results for linpack routines * linr reliability data for linpack routines * need only one value since routines DO identical operations * cwytnop performance results for xGEQRF * cwytqpb performance results for xGEQPB (preprocessing) * cwyrqpb reliability data for xGEQPB (preprocessing) * cwytqpx performance results for xGEQPX (pre + post(Chandra&Ipsen) * cwyrqpx reliability data for xGEQPX (pre + post(Chandra&Ipsen) * cwytqpy performance results for xGEQPY (pre + post(Pan&Tang) * cwyrqpy reliability data for xGEQPY (pre + post(Pan&Tang) * all others * temporary variables for time, error and so on. * ARRAYS FOR MATRICES * =================== DOUBLE PRECISION a(MMAX,NMAX), copya(MMAX,NMAX), s(MMAX), $ copys(MMAX), qraux(NMAX), svlues(4) INTEGER jpvt(NMAX) * * a, copya matrix to be factored * s, copys singular values of A * jpvt pivot vector * WORK SPACE * ========== DOUBLE PRECISION work(MMAX*NMAX+4*MMAX+NMAX),wk1(mmax,mmax) * we check later on that the length of work is sufficient * make sure to keep this check consistent with changes in * this declaration * * COMMON BLOCK FOR LAPACK ENVIRONMENT PARAMETERS * ============================================== INTEGER nblk, nmnblk, nxover common /cenvir/ nblk, nmnblk, nxover * nblk is the ideal blocksize * mnblk is the minimal blocksize * nxover is the crossover point below which an unblocked alg is used * * EXTERNAL ENTRIES * ================ * EXTERNAL DSECND, DGNTST, DQRMTX, $ DLATMS, DNRM2, iscle, iarle, find, $ DLAMCH, sfrank, flXGEQPF, flXGEQRF, $ flXGEQR2, DLASMX DOUBLE PRECISION DSECND, DNRM2, DLAMCH, DLASMX INTEGER flXGEQPF, flXGEQRF, flXGEQR2, sfrank LOGICAL iscle, iarle, find * iscle checks INTEGER scalar against bound * iarle checks INTEGER array against bound * flops... number of flops of LAPACK routines * * ***************************** * * start of executable stmts * * ***************************** * Initialize arrays describing testing options * ============================================ * DATA lint(BL1,TRANK) /0/, lint(BL1,TRCOND) /0/, $ (cwytnop(i,TRANK),i=1,MAXTEST) /MAXTEST*0/, $ (cwytnop(i,TRCOND),i=1,MAXTEST) /MAXTEST*0/ * set to zero in case we don't DO error check data LINNAMES /'DQRDC ','DGEQPF'/ data ctopt /'DGNTST','DQRMTX','DLATMS'/ cmode(GNTST,NLLMTX) = 'null matrix' cmode(GNTST,FIX1) = 'matrix w/ rank MN/2-1' cmode(GNTST,FIX2) = 'cols 2:MN full rank, rest dep.' cmode(GNTST,FULLRK) = 'full rank' cmode(GNTST,SMFRNT) = 'STRIP small cols up front, rest indep.' cmode(GNTST,SMBACK) = 'STRIP indep. cols up front, rest dep.' cmode(GNTST,PETER) = 'Peter''s: 5 small close sing. values' cmode(QRMTX,BREAK1) = 'break1 distribution' cmode(QRMTX,GEOM) = 'geometric distribution' cmode(QRMTX,ARITH) = 'arithmetic distribution' cmode(QRMTX,-BREAK1) = 'break1 distribution reversed' cmode(QRMTX,-GEOM) = 'geometric distribution reversed' cmode(QRMTX,-ARITH) = 'arithmetic distribution reversed' j = MAX(ARITH,BREAK1,GEOM) DO 230 i = -j,j cmode(LATMS,i) = cmode(QRMTX,i) 230 CONTINUE * * Envir common block initialization * ================================= * nmnblk = 1 nxover = 1 lda = mmax eps = DLAMCH('epsilon') * ***************************************************** * * read data from input file and copy to output file * * ***************************************************** * OPEN(uin,file=infile) REWIND(uin) * name of output file READ(uin,*) outfile OPEN(uoutrl,file='rank.'//outfile) OPEN(uoutfl,file='time.'//outfile) REWIND(uoutrl) REWIND(uoutfl) WRITE(uoutrl,1040) outfile WRITE(uoutfl,1040) outfile * values for m READ(uin,*) nm IF( .not. iscle('nm',nm,MAXTEST) ) STOP READ(uin,*)(am(i),i=1,nm) IF( .not. iarle('am',am,nm,lda) ) STOP WRITE(c1,'(i1)') nm fmt = '(1x,i1,'' nm'',/,1x,'//c1//'(i4,2x),'' m'')' WRITE(uoutrl,fmt) nm,(am(i),i=1,nm) WRITE(uoutfl,fmt) nm,(am(i),i=1,nm) * values for n READ(uin,*) nn IF( .not. iscle('nn',nn,MAXTEST) ) STOP READ(uin,*)(an(i),i=1,nn) IF( .not. iarle('an',an,nn,nmax) ) STOP WRITE(c1,'(i1)') nn fmt = '(1x,i1,'' nn'',/,1x,'//c1//'(i4,2x),'' n'')' WRITE(uoutrl,fmt) nn, (an(i),i=1,nn) WRITE(uoutfl,fmt) nn, (an(i),i=1,nn) * block sizes READ(uin,*) nnb IF( .not. iscle('nnb',nnb,MAXTEST) ) STOP READ(uin,*)(anb(i),i=1,nnb) IF( .not. iarle('anb',anb,nnb,NBMAX) ) STOP CALL isort(nnb,anb,'i') IF( anb(1).NE.1 ) THEN WRITE(*,*) '*** ERROR: specify nb = 1 as well ***' STOP END IF WRITE(c1,'(i1)') nnb fmt = '(1x,i1,'' nnb'',/,1x,'//c1//'(i2,2x),'' nb'')' WRITE(uoutrl,fmt) nnb, (anb(i),i=1,nnb) WRITE(uoutfl,fmt) nnb, (anb(i),i=1,nnb) * test matrix generation routines READ(uin,*) ntopt IF( .not. iscle('ntopt',ntopt,TOPTMAX) ) STOP READ(uin,*) (atopt(i),i=1,ntopt) IF( .not. iarle('atopt',atopt,ntopt,TOPTMAX) ) STOP WRITE(c1,'(i1)') ntopt fmt = '(1x,i1,'' ntopt'',/,1x,'//c1//'(i3,2x),'' topt'')' WRITE(uoutrl,fmt) ntopt, (atopt(i),i=1,ntopt) WRITE(uoutfl,fmt) ntopt, (atopt(i),i=1,ntopt) * test cases for xGNTST READ(uin,*) nmod1 IF( .not. iscle('nmod1',nmod1,MODEMAX) ) STOP READ(uin,*) (amod1(i),i=1,nmod1) IF( .not. iarle('amod1',amod1,nmod1,MODEMAX) ) STOP IF( find(GNTST,atopt,ntopt) ) THEN WRITE(c1,'(i1)') nmod1 fmt = '(1x,i1,'' nmod1'',/,1x,'//c1//'(i3,2x),'' mod1'')' WRITE(uoutrl,fmt) nmod1, (amod1(i),i=1,nmod1) WRITE(uoutfl,fmt) nmod1, (amod1(i),i=1,nmod1) END IF j = MAX(BREAK1,GEOM,ARITH) * singular value distributions for xQRMTX READ(uin,*) nmod2 IF( .not. iscle('nmod2',nmod2,MODEMAX) ) STOP READ(uin,*) (amod2(i),i=1,nmod2) IF( .not. iarle('amod2',amod2,nmod2,j) ) STOP IF( find(QRMTX,atopt,ntopt) ) THEN WRITE(c1,'(i1)') nmod2 fmt = '(1x,i1,'' nmod2'',/,1x,'//c1//'(i3,2x),'' mod2'')' WRITE(uoutrl,fmt) nmod2, (amod2(i),i=1,nmod2) WRITE(uoutfl,fmt) nmod2, (amod2(i),i=1,nmod2) END IF * singular value distributions for xLATMS READ(uin,*) nmod3 IF( .not. iscle('nmod3',nmod3,MODEMAX) ) STOP READ(uin,*) (amod3(i),i=1,nmod3) IF( .not. iarle('amod3',amod3,nmod3,j) ) STOP IF( find(LATMS,atopt,ntopt) ) THEN WRITE(c1,'(i1)') nmod3 fmt = '(1x,i1,'' nmod3'',/,1x,'//c1//'(i3,2x),'' mod3'')' WRITE(uoutrl,fmt) nmod3, (amod3(i),i=1,nmod3) WRITE(uoutfl,fmt) nmod3, (amod3(i),i=1,nmod3) END IF * strip width for xGNTST and xQRMTX READ(uin,*) strip IF( find(QRMTX,atopt,ntopt).OR.find(GNTST,atopt,ntopt) ) THEN WRITE(uoutrl,1050) strip WRITE(uoutfl,1050) strip END IF * scale factor for dependent columns in xQRMTX READ(uin,*) scale scale = eps**scale IF( find(QRMTX,atopt,ntopt) ) THEN WRITE(uoutrl,1060) scale WRITE(uoutfl,1060) scale END IF * inverse of acceptance threshold for condition number READ(uin,*) irthresh WRITE(uoutrl,1070) irthresh WRITE(uoutfl,1070) irthresh * gap around acceptance threshold READ(uin,*) gap WRITE(uoutrl,1080) gap WRITE(uoutfl,1080) gap * minimum time for a benchmark run READ(uin,*) timmin WRITE(uoutrl,1020) timmin WRITE(uoutfl,1020) timmin * seed for random number generator READ(uin,*) (iseed(i),i=1,4) IF( mod(iseed(4),2).EQ.0 ) THEN WRITE(*,1090) iseed(4) STOP END IF WRITE(uoutrl,1030) iseed WRITE(uoutfl,1030) iseed trt = DSECND() * * save values that are overwritten by xGEQPX and xGEQPY * * *************** * *************** * ** Test loop ** * *************** * *************** DO 9001 im = 1,nm m = am(im) DO 9002 in = 1,nn n = an(in) mn = min(m,n) DO 9003 itopt = 1,ntopt topt = atopt(itopt) IF( topt.EQ.GNTST ) THEN nmode = nmod1 CALL icopy(nmod1,amod1,amode) ELSEIF( topt.EQ.QRMTX ) THEN nmode = nmod2 CALL icopy(nmod2,amod2,amode) ELSEIF( topt.EQ.LATMS ) THEN nmode = nmod3 CALL icopy(nmod3,amod3,amode) END IF DO 9004 imode = 1,nmode mode = amode(imode) oiseed(1) = iseed(1) oiseed(2) = iseed(2) oiseed(3) = iseed(3) oiseed(4) = iseed(4) * * generate test matrix of size m by n using * test matrix generator indicated by 'topt' * and singular value distribution by 'mode'. * ***************************************** * IF( topt.EQ.GNTST ) THEN CALL DGNTST(mode,m,n,irthresh,gap,strip,iseed, $ rank,s,a,lda,work) ELSEIF( topt.EQ.QRMTX ) THEN CALL DQRMTX('all',scale,m,n,irthresh*gap,strip, $ mode,iseed,rank,s,a,lda,work) rank = sfrank(s,mn,irthresh) ELSEIF( topt.EQ.LATMS ) THEN CALL DLATMS(M,N,'Uniform',iseed,'nonsymmetric', $ s,mode,gap/irthresh,ONE,m,n, $ 'no packing',a,lda,work,info) IF( mode.LT.0 ) THEN CALL Dsort(mn,s,1,'decreasing') END IF rank = sfrank(s,mn,irthresh) END IF * * Save A, its singular values, and the acceptance * threshold as well as the best condition number for * R that can be achieved. Also save rank with * respect to 'irthresh'. * ================================================== * CALL DLACPY('all',m,n,a,lda,copya,lda) CALL DCOPY(mn,s,1,copys,1) IF( rank.GT.0 ) THEN nobefore = rank bstrcond = s(nobefore)/s(1) ELSE nobefore = 1 bstrcond = ZERO END IF realsmin = s(mn) * * Write info to output file and console * ===================================== WRITE(uoutrl,1200) m,n,ctopt(topt),cmode(topt,mode), $ strip,irthresh,gap, $ rank, nobefore,bstrcond, $ s(1),s(nobefore), $ s(min(mn,nobefore+1)), s(mn), $ oiseed WRITE(uoutfl,1200) m,n,ctopt(topt),cmode(topt,mode), $ strip,irthresh,gap, $ rank, nobefore,bstrcond, $ s(1),s(nobefore), $ s(min(mn,nobefore+1)), s(mn), $ oiseed * ********************** * * LINPACK QR BLAS 1 * * ********************** * DO enough runs for the aggregate runtime to be more * than ''timmin'' * runs = 0 t1 = DSECND() 10 CONTINUE CALL izero(n,jpvt) CALL DLACPY('all',m,n,copya,lda,a,lda) CALL DQRDC(a,lda,m,n,qraux,jpvt,work,1) t2 = DSECND() ttime = t2 - t1 runs = runs + 1 IF( ttime.LT.timmin ) GOTO 10 * * subtract the time for the DLACPY calls * CALL DLACPY('all',m,n,a,lda,wk1,m) t1 = DSECND() DO 20 j = 1,runs CALL DLACPY('all',m,n,copya,lda,a,lda) 20 CONTINUE ttime = (ttime - (DSECND() - t1))/runs IF( ttime.LE.ZERO ) ttime = ZERO CALL DLACPY('all',m,n,wk1,m,a,lda) * * save test results * lint(BL1,TIME) = ttime lint(BL1,FLOPS) = DBLE(flXGEQR2(m,n)) IF( ttime .EQ. ZERO ) THEN lint(BL1,MFLOPS) = ZERO ELSE lint(BL1,MFLOPS) = lint(BL1,FLOPS)/ttime/MILLION END IF lint(BL1,NORUNS) = DBLE(runs) * * * ************************************ * * LAPACK QR WITH PIVOTING (BLAS-2) * * ************************************ * DO enough runs for the aggregate runtime to be more * than ''timmin'' * runs = 0 t1 = DSECND() 100 CONTINUE CALL izero(n,jpvt) CALL DLACPY('all',m,n,copya,lda,a,lda) CALL DGEQPF(m,n,a,lda,jpvt,qraux,work,info) t2 = DSECND() ttime = t2 - t1 runs = runs + 1 IF( ttime.LT.timmin ) GOTO 100 * * subtract the time for the DLACPY calls * CALL DLACPY('all',m,n,a,lda,wk1,m) t1 = DSECND() DO 110 j = 1,runs CALL DLACPY('all',m,n,copya,lda,a,lda) 110 CONTINUE ttime = (ttime - (DSECND() - t1))/runs IF( ttime.LE.ZERO ) ttime = ZERO CALL DLACPY('all',m,n,wk1,m,a,lda) * * determine what columns would be accepted * smax = abs(a(1,1)) smin = abs(a(1,1)) mnrm = smin IF( abs(a(1,1)).LT.irthresh ) THEN taccptd = 0 tircond = abs(a(1,1)) tdrcond = ONE tismax = tircond tdsmax = ONE tisbefor = tircond tdsbefor = ONE tisafter = abs(a(min(mn,2),min(mn,2))) tdsafter = ONE tismin = abs(a(mn,mn)) IF( realsmin.GT.ZERO ) THEN tdsmin = tismin/realsmin ELSE tdsmin = ONE END IF ELSE DO 120 i = 1,mn mnrmpr = MAX(mnrm,DNRM2(i,a(1,i),1)) smaxpr = DLASMX(i)*mnrmpr sminpr = min(smin,abs(a(i,i))) IF( smaxpr*irthresh.GT.sminpr ) THEN taccptd = i - 1 GOTO 130 ELSE smax = smaxpr smin = sminpr mnrm = mnrmpr END IF 120 CONTINUE taccptd = mn 130 CONTINUE END IF * * save timing results * lint(BL2,TIME) = ttime lint(BL2,FLOPS) = lint(BL1,FLOPS) IF( ttime.EQ.ZERO ) THEN lint(BL2,MFLOPS) = ZERO ELSE lint(BL2,MFLOPS) = lint(BL1,FLOPS)/ttime/MILLION END IF lint(BL2,NORUNS) = DBLE(runs) lint(BL2,TRANK) = DBLE(taccptd) IF( smax.EQ.ZERO ) THEN lint(BL2,TRCOND) = ZERO ELSE lint(BL2,TRCOND) = smin/smax END IF lint(BL1,TRANK) = lint(BL2,TRANK) lint(BL1,TRCOND) = lint(BL2,TRCOND) * * Try for all different block sizes * *********************************** DO 9005 inb = 1,nnb nb = anb(inb) nblk = nb * * ****************************** * * LAPACK QR WITHOUT PIVOTING * * ****************************** * DO enough runs for the aggregate runtime to be more * than ''timmin'' * runs = 0 t1 = DSECND() 200 CONTINUE CALL DLACPY('all',m,n,copya,lda,a,lda) CALL DGEQRF(m,n,a,lda,qraux,work,n*nb,info) t2 = DSECND() ttime = t2 - t1 runs = runs + 1 IF( ttime.LT.timmin ) GOTO 200 * * subtract the time for the DLACPY calls * CALL DLACPY('all',m,n,a,lda,wk1,m) t1 = DSECND() DO 220 j = 1,runs CALL DLACPY('all',m,n,copya,lda,a,lda) 220 CONTINUE ttime = (ttime - (DSECND() - t1))/runs IF( ttime.LE.ZERO ) ttime = ZERO CALL DLACPY('all',m,n,wk1,m,a,lda) * * save test results * cwytnop(inb,TIME) = ttime cwytnop(inb,STFLPS) = DBLE(flXGEQR2(m,n)) cwytnop(inb,RLFLPS) = DBLE(flXGEQRF(m,n,nb)) IF( ttime.EQ.ZERO ) THEN cwytnop(inb,STMFLP) = ZERO cwytnop(inb,RLMFLP) = ZERO ELSE cwytnop(inb,STMFLP) = $ cwytnop(inb,STFLPS)/ttime/MILLION cwytnop(inb,RLMFLP) = $ cwytnop(inb,RLFLPS)/ttime/MILLION END IF cwytnop(inb,NORUNS) = DBLE(runs) * * Linpack pivoting strategy is achieved through * setting nb = 1 * * ******************************** * * BLOCK QR WITH LOCAL PIVOTING * * ******************************** job = 1 k = 0 * Length of work array for DGEQPB IF( job.EQ.1 ) THEN IF( nb.EQ.1 ) THEN ls = 2*min(m,n)+3*n ELSE ls = 2*min(m,n)+n*nb END IF ELSE IF( nb.EQ.1 ) THEN ls = 2*min(m,n)+2*n+max(k,n) ELSE ls = 2*min(m,n)+nb*nb+nb*max(k,n) END IF END IF ls = MAX(1,ls) IF( ls.GT.MMAX*NMAX+4*MMAX+NMAX ) THEN WRITE(*,*) '**error in xqr.F(DGEQPB):', $ 'workspace too short' END IF * DO enough runs for the aggregate runtime to be more * than ''timmin'' runs = 0 t1 = DSECND() 300 CONTINUE flppre = 0 flpice = 0 flppst = 0 CALL DLACPY('all',m,n,copya,lda,a,lda) CALL DGEQPB(job,m,n,k,a,lda,wk1,mmax,jpvt, $ irthresh,orthresh,rank,svlues,work,ls, $ info) t2 = DSECND() ttime = t2 - t1 runs = runs + 1 IF( ttime.LT.timmin ) GOTO 300 * * subtract the time for the DLACPY calls * CALL DLACPY('all',m,n,a,lda,wk1,m) t1 = DSECND() DO 320 j = 1,runs CALL DLACPY('all',m,n,copya,lda,a,lda) 320 CONTINUE ttime = (ttime - (DSECND() - t1))/runs IF( ttime.LE.ZERO ) ttime = ZERO CALL DLACPY('all',m,n,wk1,m,a,lda) * * save timing results * cwytqpb(inb,TIME) = ttime cwytqpb(inb,STFLPS) = lint(BL1,FLOPS) IF( ttime.EQ.ZERO ) THEN cwytqpb(inb,STMFLP) = ZERO ELSE cwytqpb(inb,STMFLP) = $ cwytqpb(inb,STFLPS)/ttime/MILLION END IF cwytqpb(inb,ICFLPS) = DBLE(flpice) cwytqpb(inb,POFLPS) = DBLE(flppst) cwytqpb(inb,RLFLPS) = DBLE(flppre)+ $ DBLE(flpice)+DBLE(flppst) IF( ttime.EQ.ZERO ) THEN cwytqpb(inb,RLMFLP) = ZERO ELSE cwytqpb(inb,RLMFLP) = $ cwytqpb(inb,RLFLPS)/ttime/MILLION END IF cwytqpb(inb,NORUNS) = DBLE(runs) cwytqpb(inb,TRANK) = DBLE(rank) cwytqpb(inb,TRCOND) = orthresh * * *********************************** * * xGEQPX: PRE and POSTPROCESSING * * * Modified Chandrasekaran & Ipsen * * *********************************** job = 1 k = 0 * Length of work array for DGEQPB IF( job.EQ.1 ) THEN IF( nb.EQ.1 ) THEN ls = 2*min(m,n)+3*n ELSE ls = 2*min(m,n)+n*nb END IF ELSE IF( nb.EQ.1 ) THEN ls = 2*min(m,n)+2*n+max(k,n) ELSE ls = 2*min(m,n)+nb*nb+nb*max(k,n) END IF END IF ls = MAX(1,ls) IF( ls.GT.MMAX*NMAX+4*MMAX+NMAX ) THEN WRITE(*,*) '**error in xqr.F (DGEQPX):', $ 'workspace too short' END IF * DO enough runs for the aggregate runtime to be more * than ''timmin'' runs = 0 t1 = DSECND() 400 CONTINUE flppre = 0 flpice = 0 flppst = 0 CALL DLACPY('all',m,n,copya,lda,a,lda) CALL DGEQPX(job,m,n,k,a,lda,wk1,mmax,jpvt, $ irthresh,orthresh,rank,svlues,work,ls, $ info) t2 = DSECND() ttime = t2 - t1 runs = runs + 1 * * Check if xGEQPX was ok. * IF( info.NE.0 ) $ WRITE(*,*) 'DGEQPX. Info:',info IF( ttime.LT.timmin ) GOTO 400 * * subtract the time for the DLACPY calls * CALL DLACPY('all',m,n,a,lda,wk1,m) t1 = DSECND() DO 420 j = 1,runs CALL DLACPY('all',m,n,copya,lda,a,lda) 420 CONTINUE ttime = (ttime - (DSECND() - t1))/runs IF( ttime.LE.ZERO ) ttime = ZERO CALL DLACPY('all',m,n,wk1,m,a,lda) * * save timing results * cwytqpx(inb,TIME) = ttime cwytqpx(inb,STFLPS) = lint(BL1,FLOPS) IF( ttime.EQ.ZERO ) THEN cwytqpx(inb,STMFLP) = ZERO ELSE cwytqpx(inb,STMFLP) = $ cwytqpx(inb,STFLPS)/ttime/MILLION END IF cwytqpx(inb,ICFLPS) = DBLE(flpice) cwytqpx(inb,POFLPS) = DBLE(flppst) cwytqpx(inb,RLFLPS) = DBLE(flppre)+ $ DBLE(flpice)+DBLE(flppst) IF( ttime.EQ.ZERO ) THEN cwytqpx(inb,RLMFLP) = ZERO ELSE cwytqpx(inb,RLMFLP) = $ cwytqpx(inb,RLFLPS)/ttime/MILLION END IF cwytqpx(inb,NORUNS) = DBLE(runs) cwytqpx(inb,TRANK) = DBLE(rank) cwytqpx(inb,TRCOND) = orthresh * * ********************************** * * xGEQPY: PRE and POSTPROCESSING * * * Modified Pan & Tang * * ********************************** job = 1 k = 0 * Length of work array for DGEQPB IF( job.EQ.1 ) THEN IF( nb.EQ.1 ) THEN ls = 2*min(m,n)+3*n ELSE ls = 2*min(m,n)+n*nb END IF ELSE IF( nb.EQ.1 ) THEN ls = 2*min(m,n)+2*n+max(k,n) ELSE ls = 2*min(m,n)+nb*nb+nb*max(k,n) END IF END IF ls = MAX(1,ls) IF( ls.GT.MMAX*NMAX+4*MMAX+NMAX ) THEN WRITE(*,*) '**error in xqr.F (DGEQPY):', $ 'workspace too short' END IF * DO enough runs for the aggregate runtime to be more * than ''timmin'' runs = 0 t1 = DSECND() 500 CONTINUE flppre = 0 flpice = 0 flppst = 0 CALL DLACPY('all',m,n,copya,lda,a,lda) CALL DGEQPY(job,m,n,k,a,lda,wk1,mmax,jpvt, $ irthresh,orthresh,rank,svlues,work,ls, $ info) t2 = DSECND() ttime = t2 - t1 runs = runs + 1 * * Check if xGEQPY was ok. * IF( info.NE.0 ) $ WRITE(*,*) 'DGEQPY. Info:',info IF( ttime.LT.timmin ) GOTO 500 * * subtract the time for the DLACPY calls * CALL DLACPY('all',m,n,a,lda,wk1,m) t1 = DSECND() DO 520 j = 1,runs CALL DLACPY('all',m,n,copya,lda,a,lda) 520 CONTINUE ttime = (ttime - (DSECND() - t1))/runs IF( ttime.LE.ZERO ) ttime = ZERO CALL DLACPY('all',m,n,wk1,m,a,lda) * * save timing results * cwytqpy(inb,TIME) = ttime cwytqpy(inb,STFLPS) = lint(BL1,FLOPS) IF( ttime.EQ.ZERO ) THEN cwytqpy(inb,STMFLP) = ZERO ELSE cwytqpy(inb,STMFLP) = $ cwytqpy(inb,STFLPS)/ttime/MILLION END IF cwytqpy(inb,ICFLPS) = DBLE(flpice) cwytqpy(inb,POFLPS) = DBLE(flppst) cwytqpy(inb,RLFLPS) = DBLE(flppre)+ $ DBLE(flpice)+DBLE(flppst) IF( ttime.EQ.ZERO ) THEN cwytqpy(inb,RLMFLP) = ZERO ELSE cwytqpy(inb,RLMFLP) = $ cwytqpy(inb,RLFLPS)/ttime/MILLION END IF cwytqpy(inb,NORUNS) = DBLE(runs) cwytqpy(inb,TRANK) = DBLE(rank) cwytqpy(inb,TRCOND) = orthresh 9005 CONTINUE * end of inb loop * * print out reliability data * ========================== * * * print out performance numbers * ============================= * WRITE(uoutfl,1210) DO 810 i = 1,LINRTS WRITE(uoutfl,1230) $ LINNAMES(i), $ lint(i,TIME), $ lint(i,MFLOPS), $ lint(i,MFLOPS), $ int(lint(i,NORUNS)), $ int(lint(i,TRANK)), $ lint(i,TRCOND) WRITE(uoutfl,1220) 810 CONTINUE DO 820 inb = 1,nnb WRITE(uoutfl,1240) $ anb(inb), $ cwytnop(inb,TIME), $ cwytnop(inb,STMFLP), $ cwytnop(inb,RLMFLP), $ int(cwytnop(inb,NORUNS)) 820 CONTINUE WRITE(uoutfl,1220) DO 830 inb = 1,nnb nb = anb(inb) * temp = cwytqpb(inb,RLFLPS) IF( temp.GT.0 ) THEN WRITE(uoutfl,1250)'DGEQPB', $ nb, $ cwytqpb(inb,TIME), $ cwytqpb(inb,STMFLP), $ cwytqpb(inb,RLMFLP), $ int(cwytqpb(inb,NORUNS)), $ int(cwytqpb(inb,TRANK)), $ cwytqpb(inb,TRCOND), $ HUNDRED*cwytqpb(inb,ICFLPS)/temp, $ HUNDRED*cwytqpb(inb,POFLPS)/temp ELSE WRITE(uoutfl,1260)'DGEQPB', $ nb, $ cwytqpb(inb,TIME), $ cwytqpb(inb,STMFLP), $ cwytqpb(inb,RLMFLP), $ int(cwytqpb(inb,NORUNS)), $ int(cwytqpb(inb,TRANK)), $ cwytqpb(inb,TRCOND) END IF * temp = cwytqpx(inb,RLFLPS) IF( temp.GT.0 ) THEN WRITE(uoutfl,1250)'DGEQPX', $ nb, $ cwytqpx(inb,TIME), $ cwytqpx(inb,STMFLP), $ cwytqpx(inb,RLMFLP), $ int(cwytqpx(inb,NORUNS)), $ int(cwytqpx(inb,TRANK)), $ cwytqpx(inb,TRCOND), $ HUNDRED*cwytqpx(inb,ICFLPS)/temp, $ HUNDRED*cwytqpx(inb,POFLPS)/temp ELSE WRITE(uoutfl,1260)'DGEQPX', $ nb, $ cwytqpx(inb,TIME), $ cwytqpx(inb,STMFLP), $ cwytqpx(inb,RLMFLP), $ int(cwytqpx(inb,NORUNS)), $ int(cwytqpx(inb,TRANK)), $ cwytqpx(inb,TRCOND) END IF * temp = cwytqpy(inb,RLFLPS) IF( temp.GT.0 ) THEN WRITE(uoutfl,1250)'DGEQPY', $ nb, $ cwytqpy(inb,TIME), $ cwytqpy(inb,STMFLP), $ cwytqpy(inb,RLMFLP), $ int(cwytqpy(inb,NORUNS)), $ int(cwytqpy(inb,TRANK)), $ cwytqpy(inb,TRCOND), $ HUNDRED*cwytqpy(inb,ICFLPS)/temp, $ HUNDRED*cwytqpy(inb,POFLPS)/temp ELSE WRITE(uoutfl,1260)'DGEQPY', $ nb, $ cwytqpy(inb,TIME), $ cwytqpy(inb,STMFLP), $ cwytqpy(inb,RLMFLP), $ int(cwytqpy(inb,NORUNS)), $ int(cwytqpy(inb,TRANK)), $ cwytqpy(inb,TRCOND) END IF * WRITE(uoutfl,1220) 830 CONTINUE 9004 CONTINUE * end of imode loop 9003 CONTINUE * end of itopt loop 9002 CONTINUE * end of in loop 9001 CONTINUE * end of im loop trt = DSECND() - trt WRITE(uoutfl,1000) trt WRITE(uoutrl,1000) trt WRITE(*,*) ' End of program' CLOSE( uin ) CLOSE( uoutrl ) CLOSE( uoutfl ) STOP * 1000 FORMAT(/,1x,'total run time: ',f8.2,' seconds') 1010 FORMAT(1x,42('*'),/,1x,'* ','time of run: ',a25,' *', $ /,1x,42('*'),/) 1020 FORMAT(1x,f5.3,' minimum time for benchmark run') 1030 FORMAT(1x,4(i5,2x),' seed for RN generator',//) 1040 FORMAT('''',a,'''',' output file') 1050 FORMAT(1x,i3,' strip width') 1060 FORMAT(1x,e8.2,' scale for dependent columns in SQRMTX') 1070 FORMAT(1x,e8.2,' inverse of acceptance threshold') 1080 FORMAT(1x,e8.2,' gap around acceptance threshold') 1090 FORMAT('*** error: iseed(3) = ',i4,' but should be odd') * 1200 FORMAT(/,1x,74('*'),/,1x,'* m:',i4,' n:',i4, $ ' using ',a6,2x,a40,' *', $ /,1x,'* ',16x,'strip: ',i2, $ ' rthresh: ',e8.2,' gap: ',e8.2,11x,' *', $ /,1x,'* ','rank: ',i4,5x,'nobefore: ',i4,5x, $ ' best rcond: ',e8.2,15x, $ ' *',/,1x,'* smax: ',e8.2,' sbefore: ',e8.2, $ ' safter: ',e8.2,' smin: ',e8.2,' *', $ /,1x,'* seed: ',4(i4,2x),41(' '),'*', $ /,1x,74('*')) 1210 FORMAT(/,1x,12x,' | ','time(secs)',' | ','mflops(std)', $ ' | ','mflops(real)',' | ','noruns',' | ', $ 'rank',' | ',' rcond ',' | ','% ice',' | ','%post', $ /,1x,100('=')) 1220 FORMAT(1x,100('-')) 1230 FORMAT(1x,a6,' | ',e8.2,' | ',f7.2,' | ', $ f7.2,' | ',1x,i4,1x,' | ',i4,' | ',e8.2) 1240 FORMAT(1x,'DGEQRF',' nb:',i2,' | ',e8.2, $ ' | ',f7.2,' | ',f7.2,' | ',1x,i4) 1250 FORMAT(1x,a6,' nb:',i2,' | ',e8.2,' | ', $ f7.2,' | ',f7.2,' | ',1x,i4,1x, $ ' | ',i4,' | ',e8.2,' | ',f5.2,' | ',f5.2) 1260 FORMAT(1x,a6,' nb:',i2,' | ',e8.2,' | ', $ f7.2,' | ',f7.2,' | ',1x,i4,1x, $ ' | ',i4,' | ',e8.2) * 1400 FORMAT(/,1x,'DQRDC: ',6x,' svd:',e8.2) 1410 FORMAT(/,1x,'DGEQPF:',6x,' svd:',e8.2,' qrf:',e8.2, $ ' ort:',e8.2) 1420 FORMAT(/,1x,'DGEQRF: nb:',i2,' svd:',e8.2, $ ' qrf:',e8.2,' ort:',e8.2) 1430 FORMAT(1x,'DGEQPB: nb:',i2, $ ' svd:',e8.2,' qrf:',e8.2,' ort:',e8.2) 1440 FORMAT(1x,'DGEQPX: nb:',i2, $ ' svd:',e8.2,' qrf:',e8.2,' ort:',e8.2) 1450 FORMAT(1x,'DGEQPY: nb:',i2, $ ' svd:',e8.2,' qrf:',e8.2,' ort:',e8.2) * * * END SHAR_EOF fi # end of overwriting check if test -f 'dqrmtx.f' then echo shar: will not over-write existing file "'dqrmtx.f'" else cat << SHAR_EOF > 'dqrmtx.f' SUBROUTINE DQRMTX( OPT, SCALE, M, N, RCOND, WIDTH, $ MODE, ISEED, RANK, S, A, LDA, WORK ) * * 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.84 $ * $Date: 96/12/30 16:59:18 $ * CHARACTER*1 OPT INTEGER M, N, WIDTH, LDA, RANK, MODE INTEGER ISEED( 4 ) DOUBLE PRECISION SCALE, RCOND, A( LDA, * ), S( * ), WORK( * ) * * Purpose: * ======= * * generates a matrix for testing DGEQPF. The independent and * dependent columns of A are arranged in a zebra-like fashion. * That is, if m = 5, n = 12, and width = 2, * columns 1:2 are independent * columns 3:4 are a linear combination of columns 1:2 * columns 5:6 are independent * columns 7:8 are a linear combination of columns 5:6 or * [1:6], depending on the value of 'opt'. * column 9 is independent (there can't be more than * min(m,n) independent columns) * columns 10:12 are again linear combinations of previous * columns * * Arguments: * ========= * * OPT (input) CHARACTER*1 * OPT == 'l' or 'L': dependent columns are linear * combinations of the last set of * independent columns * any other value : dependent columns are linear * combinations of all previous * independent columns * SCALE (input) DOUBLE PRECISION * dependent columns are a random linear combination of * previous ones multiplied by SCALE. * * M (input) INTEGER * The number of rows of the matrix A. * * N (input) INTEGER * The number of columns of the matrix A. * * RCOND (input) DOUBLE PRECISION * 1/RCOND is the condition number of the matrix to be * generated. Singular values for the submatrix consisting * of independent columns are generated between * 1 and RCOND dependent on MODE. * * WIDTH (input) INTEGER * The width of a strip of dependent or independent columns. * * MODE (input) INTEGER * is passed to DLATMS to determine how diagonal entries * are generated between 1 and RCOND. * MODE = {-,+}1 : all diagonal entries are RCOND except for * {last,first} one. * MODE = {-,+}2 : all diagonal entries are 1 except for * {first,last} one. * MODE = {-,+}3 : exponentially {declining,increasing} * MODE = {-,+}4 : arithmetically {decl.,incr.} * * ISEED (input/output) INTEGER array, dimension(4) * Seed for random number generator. ISEED(4) must be odd. * * RANK (output) INTEGER * The number of independent columns generated. Note that * this need not necessarily be the numerical rank of A * as determined by the SVD due to the permutation generated * by adding the columns which are linear combinations of * previous ones. * * S (output) DOUBLE PRECISION array (min(M,N)) * The singular values of A * * A (output) DOUBLE PRECISION array, dimension (M,N) * matrix with singular value distribution given in S * and pattern of dependent/independent columns determined * by WIDTH. * * LDA (input) INTEGER * leading dimension of A. * * WORK (workspace) DOUBLE PRECISION array, * dimension max(3*min(m,n),width*width) if OPT == 'L' or 'l' * dimension max(3*min(m,n),width*width*2) otherwise * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER MN, WLAST, NSTRPS, INFO, OFFSET, $ NCOLS, CLSLFT, I DOUBLE PRECISION DUMMY * .. * .. * .. External Subroutines EXTERNAL DLATMS, DLACPY, LSAME, $ DGEBD2, DBDSQR, DLARNV LOGICAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC MIN, MOD, SQRT * .. * .. Executable Statements .. MN = MIN( M, N ) * * How many strips do fit and what is width of last strip? * WLAST = MOD( N, WIDTH ) IF( WLAST.EQ.0 ) THEN NSTRPS = N/WIDTH WLAST = WIDTH ELSE NSTRPS = N/WIDTH + 1 END IF * * What is the rank of A? * IF( MOD( NSTRPS, 2 ).EQ.0 ) THEN RANK = MIN( MN, NSTRPS/2*WIDTH ) ELSE RANK = MIN( MN, (NSTRPS-1)/2*WIDTH + WLAST ) END IF * * How many strips is the matrix of size m -by- rank partitioned into? * WLAST = MOD( RANK, WIDTH ) IF( WLAST.EQ.0 ) THEN NSTRPS = RANK/WIDTH WLAST = WIDTH ELSE NSTRPS = RANK/WIDTH + 1 END IF * * Generate 'rank' independent columns in * A(:,(nstrips-1)*width+1:(nstrips-1)*width+rank)) * OFFSET = ( NSTRPS-1 )*WIDTH CALL DLATMS( M, RANK, 'Uniform', ISEED, 'Nonsymmetric', $ S, MODE, ONE/RCOND, ONE, M, RANK, 'No Packing', $ A( 1, OFFSET+1 ), LDA, WORK, INFO ) IF( INFO.GT.0 ) THEN WRITE(*,999) INFO STOP END IF * * Redistribute independent columns and generate dependent * ones in columns 1 through offset+rank * DO 10 I = 1,NSTRPS-1 CALL DLACPY( 'full matrix', M, WIDTH, $ A( 1, OFFSET+( I-1 )*WIDTH+1 ), LDA, $ A( 1, 2*( I-1 )*WIDTH+1 ),LDA ) IF( LSAME( OPT, 'L' ) ) THEN NCOLS = WIDTH ELSE NCOLS = MIN( 2, I )*WIDTH END IF CALL DLARNV( 1, ISEED, NCOLS*WIDTH, WORK( 1 ) ) CALL DGEMM( 'no transpose', 'no transpose', M, WIDTH, NCOLS, $ SCALE, A( 1, ( 2*I-1 )*WIDTH-NCOLS+1 ), LDA, $ WORK, NCOLS, ZERO, A( 1,( 2*I-1 )*WIDTH+1 ), LDA ) 10 CONTINUE * * generate dependent columns offset+rank+1 through n * CLSLFT = N-( OFFSET+RANK ) IF( CLSLFT.GT.0 ) THEN IF( LSAME( OPT, 'L' ) ) THEN NCOLS = WLAST ELSE NCOLS = MIN( OFFSET+RANK, WLAST+WIDTH ) END IF CALL DLARNV( 1, ISEED, NCOLS*CLSLFT, WORK( 1 ) ) CALL DGEMM( 'no transpose', 'no transpose', M, CLSLFT, NCOLS, $ SCALE, A( 1, OFFSET+RANK+1-NCOLS ), LDA, WORK, $ NCOLS, ZERO,A( 1, OFFSET+RANK+1 ), LDA ) END IF * * compute singular value decomposition of A * CALL DLACPY( 'full matrix', M, N, A, LDA, WORK( MN+1 ), M ) CALL DGEBD2( M, N, WORK( MN+1 ), M, S, WORK( 1 ), $ WORK( MN+M*N+1 ), WORK( 2*MN+M*N+1 ), $ WORK( 3*MN+M*N+1 ), INFO ) CALL DBDSQR( 'upper', MN, 0, 0, 0, S, WORK( 1 ), $ DUMMY, MN, DUMMY, 1, DUMMY, MN, WORK( MN+1 ), INFO ) RETURN 999 FORMAT( '** ERROR in sqrmtx: DLATMS returns INFO = ',i2 ) * * End of DQRMTX * END SHAR_EOF fi # end of overwriting check if test -f 'dtrqpx.f' then echo shar: will not over-write existing file "'dtrqpx.f'" else cat << SHAR_EOF > 'dtrqpx.f' SUBROUTINE DTRQPX( JOB, M, N, K, A, LDA, C, LDC, JPVT, IRCOND, $ ORCOND, RANK, SVLUES, WORK, LWORK, 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.84 $ * $Date: 96/12/30 16:59:18 $ * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, RANK, LWORK, INFO DOUBLE PRECISION IRCOND, ORCOND * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ), SVLUES( 4 ) DOUBLE PRECISION WORK( LWORK ) INTEGER JPVT( * ) * .. * * Purpose * ======= * * DTRQPX 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 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. 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) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the orthogonal 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) DOUBLE PRECISION * 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) DOUBLE PRECISION * 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) 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) DOUBLE PRECISION array, dimension ( LWORK ) * * LWORK (input) INTEGER * The dimension of array WORK. LWORK >= MN+MAX(N,2*MN), where * MN = min(M,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, DTRQXC, DTRRNK * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * MN = MIN( M, N ) NB = ILAENV( INB, 'DGEQRF', ' ', 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 ELSE IF( LWORK.LT.MAX(1,N+3*MN) ) THEN INFO = -15 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTRQPX', -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 DTRRNK( MN, A, LDA, RCOND, RANK, WORK, INFO ) * * ************************ * * First call to xTRQXC * * ************************ * * Get tighter bounds for the value RANK. * CALL DTRQXC( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ RANK, SVLUES, RCNR, RCNRP1, WORK, 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 DTRQXC( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ RANK, SVLUES, RCNR, RCNRP1, WORK, 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 DTRQPX * END SHAR_EOF fi # end of overwriting check if test -f 'dtrqpy.f' then echo shar: will not over-write existing file "'dtrqpy.f'" else cat << SHAR_EOF > 'dtrqpy.f' SUBROUTINE DTRQPY( JOB, M, N, K, A, LDA, C, LDC, JPVT, IRCOND, $ ORCOND, RANK, SVLUES, WORK, LWORK, 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.84 $ * $Date: 96/12/30 16:59:19 $ * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, RANK, LWORK, INFO DOUBLE PRECISION IRCOND, ORCOND * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ), SVLUES( 4 ) DOUBLE PRECISION WORK( LWORK ) INTEGER JPVT( * ) * .. * * Purpose * ======= * * DTRQPY 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 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. 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) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the orthogonal 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) DOUBLE PRECISION * 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) DOUBLE PRECISION * 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) DOUBLE PRECISION array, dimension ( LWORK ) * * LWORK (input) INTEGER * The dimension of array WORK. LWORK >= N+3*MN, where * MN = min(M,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, DTRQYC, DTRRNK * .. * .. Intrinsic Functions .. INTRINSIC MIN, MAX * .. * .. Executable Statements .. * MN = MIN( M, N ) NB = ILAENV( INB, 'DGEQRF', ' ', 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 ELSE IF( LWORK.LT.MAX(1,N+3*MN) ) THEN INFO = -15 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTRQPY', -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 DTRRNK( MN, A, LDA, RCOND, RANK, WORK, INFO ) * * ************************ * * First call to xTRQYC * * ************************ * * Get tighter bounds for the value RANK. * CALL DTRQYC( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ RANK, SVLUES, RCNR, RCNRP1, WORK, 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 DTRQYC( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ RANK, SVLUES, RCNR, RCNRP1, WORK, 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 DTRQPY * END SHAR_EOF fi # end of overwriting check if test -f 'dtrqxc.f' then echo shar: will not over-write existing file "'dtrqxc.f'" else cat << SHAR_EOF > 'dtrqxc.f' SUBROUTINE DTRQXC( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ RANK, SVLUES, RCNR, RCNRP1, WORK, 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.84 $ * $Date: 96/12/30 16:59:20 $ * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, RANK, INFO DOUBLE PRECISION RCNR, RCNRP1 * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ), WORK( * ), $ SVLUES( 4 ) INTEGER JPVT( * ) * .. * * Purpose * ======= * * DTRQXC 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 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. 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) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the orthogonal 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 * Th 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) 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 * Th estimate for the inverse of the condition number of block * R(1:RANK,1:RANK). * * RCNRP1 (output) DOUBLE PRECISION * Th estimate for the inverse of the condition number of block * R(1:RANK+1,1:RANK+1). * * WORK (workspace) DOUBLE PRECISION array, * dimension ( MN+MAX(N,2*MN) ), where MN=MIN(M,N). * * INFO (output) INTEGER * = 0: Successful exit. * < 0: If info = -i, the i-th argument had an illegal value. * = 1: Exceeded the allowed maximum number of steps. That is, * the matrix presents a slow convergence. * * * =================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, F PARAMETER ( F = 0.5D+0, ONE = 1.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 COSINE, SINE, SMAX, SMAXPR, SMIN, SMINPR, $ SMXRP1 LOGICAL PERMUT INTEGER J, MN, MXSTPS, NACPTD INTEGER NS * .. * .. External Subroutines .. EXTERNAL DSCAL * .. * .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DLASMX, DNRM2 EXTERNAL IDAMAX, DLASMX, DNRM2 * .. * .. 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 WORK(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 WORK( J ) = DNRM2( 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 DGLBIF( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ F, RANK, PERMUT, WORK( MN+1 ), INFO ) * * If necessary, update the contents of WORK(RANK). * IF( PERMUT ) $ WORK( RANK ) = DNRM2( 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 DGLBIF( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ F, RANK+1, PERMUT, WORK( 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. * WORK( RANK+1 ) = DNRM2( 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 DCNIIF( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ WORK, F, RANK+1, PERMUT, WORK( 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 DCNIIF( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ WORK, F, RANK, PERMUT, WORK( 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 vector SVLUES and variables RCNR and RCNRP1 * * ************************************************************** * * Computation of the largest singular value and the smallest * singular value of A(1:RANK,1:RANK). * SMAX = ABS( A( 1, 1 ) ) WORK( 1 ) = ONE SMIN = SMAX WORK( MN+1 ) = ONE * DO 30 J = 2, RANK CALL DLAIC1( 1, J-1, WORK( 1 ), SMAX, $ A( 1, J ), A( J, J ), SMAXPR, SINE, COSINE ) CALL DSCAL( J-1, SINE, WORK( 1 ), 1 ) WORK( J ) = COSINE SMAX = SMAXPR CALL DLAIC1( 2, J-1, WORK( MN+1 ), SMIN, $ A( 1, J ), A( J, J ), SMINPR, SINE, COSINE ) CALL DSCAL( 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 DLAIC1( 1, RANK, WORK( 1 ), SMAX, $ A( 1, RANK+1 ), A( RANK+1, RANK+1 ), SMAXPR, $ SINE, COSINE ) SMAX = SMAXPR CALL DLAIC1( 2, RANK, WORK( MN+1 ), SMIN, $ A( 1, RANK+1 ), A( RANK+1, RANK+1 ), SMINPR, $ SINE, COSINE ) CALL DSCAL( 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 DLAIC1( 2, J-1, WORK( MN+1 ), SMIN, $ A( 1, J ), A( J, J ), SMINPR, SINE, COSINE ) CALL DSCAL( 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 DTRQXC * END SUBROUTINE DGLBIF( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ F, RANK, PERMUT, WORK, INFO ) * * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, RANK, INFO DOUBLE PRECISION F LOGICAL PERMUT * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ), WORK( * ) INTEGER JPVT( * ) * .. * * Purpose * ======= * * DGLBIF 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 and permuts and retriangularizes * matrix A. It does only one permutation. * * 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. 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) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the orthogonal 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 * Th estimate for the rank. 1 <= RANK <= MIN(M,N). * * PERMUT (output) LOGICAL * Tells if a permutation occurred. * * WORK (workspace) DOUBLE PRECISION array, * dimension ( MAX( N, 2*MIN(M,N) ) ) * * INFO (output) INTEGER * = 0: Successful exit. * < 0: If info = -i, the i-th argument had an illegal value. * * ===================================================================== * * .. Local Scalars .. INTEGER MN, JJ, J, ITEMP * .. * .. Local Arrays .. DOUBLE PRECISION RDUMMY( 1, 1 ) * .. * .. External Subroutines .. EXTERNAL DCOPY, DGRET * .. * .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DNRM2 EXTERNAL IDAMAX, DNRM2 * .. * .. Executable Statements .. * MN = MIN( M, N ) INFO = 0 * * Quick return if possible. * IF( ( MN.EQ.0 ).OR.( RANK.EQ.N ).OR.( RANK.EQ.0 ) ) THEN PERMUT = .FALSE. RETURN END IF * * Compute the norms of the columns of block A(RANK:M,RANK:N) * and store them in vector WORK(RANK:N). * DO 10 J = RANK, N WORK( J ) = $ DNRM2( 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 WORK(RANK:N). * JJ = RANK - 1 + IDAMAX( N-RANK+1, WORK( RANK ), 1) * * Determine if a permutation must occur. * PERMUT = ( ( JJ.GT.RANK ).AND. $ ( ( ABS( WORK( JJ ) )*F ).GT.ABS( WORK( 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 DCOPY( MIN( MN, JJ ), A( 1, JJ ), 1, WORK, 1 ) DO 20 J = JJ-1, RANK, -1 CALL DCOPY( MIN( MN, J+1 ), A( 1, J ), 1, $ A( 1, J+1 ), 1 ) 20 CONTINUE CALL DCOPY( 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 DGRET( JOB, MIN( M, JJ )-RANK+1, N-RANK+1, K, $ A( RANK, RANK ), LDA, RDUMMY, 1, $ WORK, INFO ) ELSE IF( JOB.EQ.2 ) THEN CALL DGRET( JOB, MIN( M, JJ )-RANK+1, N-RANK+1, K, $ A( RANK, RANK ), LDA, C( RANK, 1 ), LDC, $ WORK, INFO ) ELSE IF( JOB.EQ.3 ) THEN CALL DGRET( JOB, MIN( M, JJ )-RANK+1, N-RANK+1, K, $ A( RANK, RANK ), LDA, C( 1, RANK ), LDC, $ WORK, INFO ) END IF END IF RETURN * * End of DGLBIF * END SUBROUTINE DCNIIF( JOB, M, N, K, A, LDA, C, LDC, JPVT, VNORM, $ F, RANK, PERMUT, WORK, INFO ) * * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, RANK, INFO DOUBLE PRECISION F LOGICAL PERMUT * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ), VNORM( * ), WORK( * ) INTEGER JPVT( * ) * .. * * Purpose * ======= * * DCNIIF 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 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. 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) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the orthogonal 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 * Th estimate for the rank. 1 <= RANK <= MIN(M,N). * * PERMUT (output) LOGICAL * Tells if a permutation occurred. * * WORK (workspace) DOUBLE PRECISION array, dimension ( 2*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, ONE PARAMETER ( SF = 1.0D+2, ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER MN, JJ, J, ITEMP DOUBLE PRECISION SMAX, SMIN, SMINPR, SINE, COSINE, TEMP , $ RDUMMY( 1 ) * .. * .. External Subroutines .. EXTERNAL DCOPY, DTRSV, DHESS * .. * .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DNRM2, DLAMCH, DLASMX EXTERNAL IDAMAX, DNRM2, 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 ) = ONE DO 10 J = 2, RANK CALL DLAIC1( 2, J-1, WORK( 1 ), SMIN, A( 1, J ), $ A( J , J ), SMINPR, SINE, COSINE ) CALL DSCAL( 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 put into vector * WORK(1:RANK). * CALL DTRSV( 'Upper', 'No transpose', 'No unit', $ RANK, A, LDA, WORK, 1) * * Find the index with largest absolute value in vector * WORK(1:RANK). * JJ = IDAMAX( 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 DCOPY( RANK, A( 1, JJ ), 1, WORK, 1 ) DO 20 J = JJ+1, RANK CALL DCOPY( J, A( 1, J ), 1, A( 1, J-1 ), 1 ) 20 CONTINUE CALL DCOPY( 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 DHESS( JOB, RANK-JJ+1, N-JJ+1, K, $ A( JJ, JJ ), LDA, RDUMMY, 1, $ WORK, INFO ) ELSE IF( JOB.EQ.2 ) THEN CALL DHESS( JOB, RANK-JJ+1, N-JJ+1, K, $ A( JJ, JJ ), LDA, C( JJ, 1 ), LDC, $ WORK, INFO ) ELSE IF( JOB.EQ.3 ) THEN CALL DHESS( JOB, RANK-JJ+1, N-JJ+1, K, $ A( JJ, JJ ), LDA, C( 1, JJ ), LDC, $ WORK, INFO ) END IF END IF END IF RETURN * * End of DCNIIF * END SUBROUTINE DGRET( JOB, M, N, K, A, LDA, C, LDC, WORK, INFO ) * * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, INFO * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ), WORK( * ) * .. * * Purpose * ======= * * DGRET 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 orthogonal transformations applied to matrix A can be also * applied to matrix C. * * Parameters * ========== * * 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. 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) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the orthogonal 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) DOUBLE PRECISION array, dimension ( 2*M ) * If the block algorithm is used, the size of this workspace * must be ( 2*M ). * In this case this vector will contain the sines and cosines * of the angles of the Givens Rotations to be applied. * * INFO (output) INTEGER * = 0: Successful exit. * < 0: If info = -i, the i-th argument had an illegal value. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Common Blocks .. INTEGER NB COMMON /BSPRQR/ NB * .. * .. Local Scalars .. INTEGER I, J, JB, ITEMP DOUBLE PRECISION R, COSINE, SINE * .. * .. External Subroutines .. EXTERNAL DLARTG, DROT * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. 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 vector WORK. * DO 10 I = M, 2, -1 CALL DLARTG( A( I-1, 1 ), A( I, 1 ), $ WORK( I ), WORK( M+I ), R ) A( I-1, 1 ) = R A( I, 1 ) = ZERO 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 DROT( J+JB-I, A( I-1, I ), LDA, A( I, I ), LDA, $ WORK( I ), WORK( M+I ) ) 30 CONTINUE DO 40 I = MIN( M, J-1 ), 2, -1 CALL DROT( JB, A( I-1, J ), LDA, A( I, J ), LDA, $ WORK( I ), WORK( M+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 DROT( JB, C( I-1, J ), LDC, C( I, J ), LDC, $ WORK( I ), WORK( M+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 DROT( K, C( 1, I-1 ), 1, C( 1, I ), 1, $ WORK( I ), WORK( M+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 DLARTG( A( ITEMP, 1 ), A( I , 1 ), COSINE, SINE, R ) A( ITEMP, 1 ) = R A( I, 1 ) = ZERO * * Update columns I:N of matrix A. * CALL DROT( 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 DROT( 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 DROT( K, C( 1, ITEMP ), 1, C( 1, I ), 1, $ COSINE, SINE ) END IF 90 CONTINUE END IF RETURN * * End of DGRET * END SUBROUTINE DHESS( JOB, M, N, K, A, LDA, C, LDC, WORK, INFO ) * * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, INFO * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ), WORK( * ) * .. * * Purpose * ======= * * DHESS 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 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. 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) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the orthogonal 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) DOUBLE PRECISION array, dimension ( 2*M ) * If the block algorithm is used, the size of this workspace * must be ( 2*M ). * In this case this vector will contain the sines and cosines * of the angles of the Givens Rotations to be applied. * * INFO (output) INTEGER * = 0: Successful exit. * < 0: If info = -i, the i-th argument had an illegal value. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Common Blocks .. INTEGER NB COMMON /BSPRQR/ NB * .. * .. Local Scalars .. INTEGER I, J, ITEMP, JB DOUBLE PRECISION R, COSINE, SINE * .. * .. External Subroutines .. EXTERNAL DLARTG, DROT * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. 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 vector WORK. * DO 10 J = 1, N, NB JB = MIN( NB, N-J+1 ) DO 20 I = 2, MIN( M, J ) CALL DROT( JB, A( I-1, J ), LDA, A( I, J ), LDA, $ WORK( I ), WORK( M+I ) ) 20 CONTINUE DO 30 I = J+1, MIN( M, J+JB ) ITEMP = I-1 CALL DLARTG( A( ITEMP, ITEMP ), A( I, ITEMP ), $ WORK( I ), WORK( M+I ), R ) A( ITEMP, ITEMP ) = R A( I, ITEMP ) = ZERO CALL DROT( J+JB-I, A( ITEMP, I ), LDA, $ A( I, I ), LDA, $ WORK( I ), WORK( M+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 DROT( JB, C( I-1, J ), LDC, C( I, J ), LDC, $ WORK( I ), WORK( M+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 DROT( K, C( 1, I-1 ), 1, C( 1, I ), 1, $ WORK( I ), WORK( M+I ) ) 60 CONTINUE END IF ELSE * * Non-Block Algorithm * =================== * DO 80 I = 2, M ITEMP = I - 1 * * Compute the rotation parameters. * CALL DLARTG( A( ITEMP, ITEMP ), A( I, ITEMP ), $ COSINE, SINE, R ) * * Update columns I-1:N of matrix A. * A( ITEMP, ITEMP ) = R A( I, ITEMP ) = ZERO CALL DROT( 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 DROT( 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 DROT( K, C( 1, ITEMP ), 1, C( 1, I ), 1, $ COSINE, SINE ) END IF 80 CONTINUE END IF RETURN * * End of DHESS * END SHAR_EOF fi # end of overwriting check if test -f 'dtrqyc.f' then echo shar: will not over-write existing file "'dtrqyc.f'" else cat << SHAR_EOF > 'dtrqyc.f' SUBROUTINE DTRQYC( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ RANK, SVLUES, RCNR, RCNRP1, WORK, 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.84 $ * $Date: 96/12/30 16:59:21 $ * * .. Scalars Arguments .. INTEGER JOB, M, N, K, LDA, LDC, RANK, INFO DOUBLE PRECISION RCNR, RCNRP1 * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ), WORK( * ), $ SVLUES( 4 ) INTEGER JPVT( * ) * .. * * Purpose * ======= * * DTRQYC 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (N+3*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, ONE PARAMETER ( FP = 0.9D+0, SF = 1.0D+2, ONE = 1.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 COSINE, DIAG, F, SMAX, SMAXPR, SMIN, SMINPR, $ SMNRP1, SMXRP1, SINE, TEMP INTEGER NS * .. * .. Local Arrays .. DOUBLE PRECISION RDUMMY( 1, 1 ) * .. * .. External Subroutines .. EXTERNAL DSCAL, DLAIC1, DTRSV, DLARTG, $ DGRET, DHESS, DSWAP, DCOPY * .. * .. External Functions .. EXTERNAL IDAMAX, DNRM2, DLASMX, DLAMCH INTEGER IDAMAX DOUBLE PRECISION DNRM2, DLASMX, DLAMCH * .. * .. Intrinsic Functions .. INTRINSIC ABS, SQRT, DBLE, MAX, MIN * .. * .. 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( 'DTRQYC', -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 + IDAMAX( N-MN+1, A( MN, MN ), LDA ) IF( JJ.GT.MN ) THEN CALL DSWAP( 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 ) = ONE SMIN = SMAX WORK( MN+1 ) = ONE DO 10 J = 2, RANK CALL DLAIC1( 1, J-1, WORK( 1 ), SMAX, A( 1, J ), $ A( J, J ), SMAXPR, SINE, COSINE ) CALL DSCAL( J-1, SINE, WORK( 1 ), 1 ) WORK( J ) = COSINE SMAX = SMAXPR * CALL DLAIC1( 2, J-1, WORK( MN+1 ), SMIN, A( 1, J ), $ A( J, J ), SMINPR, SINE, COSINE ) CALL DSCAL( 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 DTRSV( '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 = IDAMAX( 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 DCOPY( RANK, A( 1, JJ ), 1, WORK( 1 ), 1 ) DO 20 J = JJ+1, RANK CALL DCOPY( J, A( 1, J ), 1, A( 1, J-1 ), 1 ) 20 CONTINUE CALL DCOPY( 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 DHESS( JOB, RANK-JJ+1, N-JJ+1, K, $ A( JJ, JJ ), LDA, RDUMMY, 1, $ WORK( 1 ), INFO ) ELSE IF( JOB.EQ.2 ) THEN CALL DHESS( JOB, RANK-JJ+1, N-JJ+1, K, $ A( JJ, JJ ), LDA, C( JJ, 1 ), LDC, $ WORK( 1 ), INFO ) ELSE IF( JOB.EQ.3 ) THEN CALL DHESS( JOB, RANK-JJ+1, N-JJ+1, K, $ A( JJ, JJ ), LDA, C( 1, JJ ), LDC, $ WORK( 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 WORK(1:N). * DO 100 J = 1, N WORK( J ) = DNRM2( 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(N+1:N+MN) will contain the left singular vector. * SMIN = ABS( A( 1, 1 ) ) WORK( N+1 ) = ONE DO 110 J = 2, RANK CALL DLAIC1( 2, J-1, WORK( N+1 ), SMIN, A( 1, J ), $ A( J , J ), SMINPR, SINE, COSINE ) CALL DSCAL( J-1, SINE, WORK( N+1 ), 1 ) WORK( N+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 DLARTG( A( I, II ), DIAG, COSINE, SINE, TEMP ) DIAG = TEMP 120 CONTINUE * CALL DLAIC1( 2, RANK, WORK( N+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 DCOPY( MIN( MN, II ), A( 1, II ), 1, $ WORK( N+MN+1 ), 1 ) DO 130 J = II-1, RANK+1, -1 CALL DCOPY( MIN( MN, J+1 ), A( 1, J ), 1 , $ A( 1, J+1 ), 1 ) 130 CONTINUE CALL DCOPY( MIN( MN, II ), WORK( N+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 WORK(1:N). * TEMP = WORK( II ) DO 150 J = II-1, RANK+1, -1 WORK( J+1 ) = WORK( J ) 150 CONTINUE WORK( RANK+1 ) = TEMP * * Retriangularize matrix A after permutation. * IF( JOB.EQ.1 ) THEN CALL DGRET( JOB, MIN( M, II )-RANK, N-RANK, K, $ A( RANK+1, RANK+1 ), LDA, RDUMMY, 1, $ WORK( N+MN+1 ), INFO ) ELSE IF( JOB.EQ.2 ) THEN CALL DGRET( JOB, MIN( M, II )-RANK, N-RANK, K, $ A( RANK+1, RANK+1 ), LDA, C( RANK+1, 1 ), $ LDC, WORK( N+MN+1 ), INFO ) ELSE IF( JOB.EQ.3 ) THEN CALL DGRET( JOB, MIN( M, II )-RANK, N-RANK, K, $ A( RANK+1, RANK+1 ), LDA, C( 1, RANK+1 ), $ LDC, WORK( N+MN+1 ), INFO ) END IF * * *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* * * Estimate the largest singular value * * *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* * ITEMP = IDAMAX( RANK+1, WORK, 1 ) SMXRP1 = DLASMX( RANK+1 )*WORK( 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. * CALL DCOPY( RANK, WORK( N+1 ), 1, WORK( N+MN+1 ), 1 ) CALL DSCAL( RANK, SINE, WORK( N+MN+1 ), 1 ) WORK( N+MN+RANK+1 ) = COSINE * * Obtain the right singular vector from the left one. * CALL DTRSV( 'Upper', 'No transpose', 'No unit', $ RANK+1, A, LDA, WORK( N+MN+1 ), 1 ) * JJ = IDAMAX( RANK+1, WORK( N+MN+1 ), 1 ) * * *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* * * Permut column JJ to position RANK+1 * * *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* * IF( JJ.LT.( RANK+1 ) ) THEN * * Exchange cyclically to the left the columns of A * between JJ and RANK+1, that is, JJ->RANK+1,JJ+1->JJ, * JJ+2->JJ+1,...,RANK+1->RANK. * CALL DCOPY( RANK+1, A( 1, JJ ), 1, $ WORK( N+MN+1 ), 1 ) DO 160 J = JJ+1, RANK+1 CALL DCOPY( J, A( 1, J ), 1, $ A( 1, J-1 ), 1 ) 160 CONTINUE CALL DCOPY( RANK+1, WORK( N+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 WORK. * TEMP = WORK( JJ ) DO 180 J = JJ+1, RANK+1 WORK( J-1 ) = WORK( J ) 180 CONTINUE WORK( RANK+1 ) = TEMP * * Retriangularize matrix A after the permutation. * IF( JOB.EQ.1 ) THEN CALL DHESS( JOB, RANK-JJ+2, N-JJ+1, K, $ A( JJ, JJ ), LDA, RDUMMY, 1, $ WORK( N+MN+1 ), INFO ) ELSE IF( JOB.EQ.2 ) THEN CALL DHESS( JOB, RANK-JJ+2, N-JJ+1, K, $ A( JJ, JJ ), LDA, C( JJ, 1 ), LDC, $ WORK( N+MN+1 ), INFO ) ELSE IF( JOB.EQ.3 ) THEN CALL DHESS( JOB, RANK-JJ+2, N-JJ+1, K, $ A( JJ, JJ ), LDA, C( 1, JJ ), LDC, $ WORK( N+MN+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(N+1:N+MN) will contain the left singular * vector. * SMIN = ABS( A( 1, 1 ) ) WORK( N+1 ) = ONE DO 190 J = 2, RANK CALL DLAIC1( 2, J-1, WORK( N+1 ), SMIN, $ A( 1, J ), A( J , J ), SMINPR, $ SINE, COSINE ) CALL DSCAL( J-1, SINE, WORK( N+1 ), 1 ) WORK( N+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, WORK( RANK+1 ), 1 ) IF( ( JJ.GT.( RANK+1 ) ).AND. $ ( F*ABS( WORK( JJ ) ).GT.ABS( WORK( RANK+1 ) ) ) ) THEN * * Exchange column JJ to position RANK+1. * CALL DCOPY( MIN( MN, JJ ), A( 1, JJ ), 1, $ WORK( N+MN+1 ), 1 ) DO 200 J = JJ-1, RANK+1, -1 CALL DCOPY( MIN( MN, J+1 ), A( 1, J ), 1 , $ A( 1, J+1 ), 1 ) 200 CONTINUE CALL DCOPY( MIN( MN, JJ ), WORK( N+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 DGRET( JOB, MIN( M, JJ )-RANK, N-RANK, K, $ A( RANK+1, RANK+1 ), LDA, RDUMMY, 1, $ WORK( N+MN+1 ), INFO ) ELSE IF( JOB.EQ.2 ) THEN CALL DGRET( JOB, MIN( M, JJ )-RANK, N-RANK, K, $ A( RANK+1, RANK+1 ), LDA, C( RANK+1, 1 ), $ LDC, WORK( N+MN+1 ), INFO ) ELSE IF( JOB.EQ.3 ) THEN CALL DGRET( JOB, MIN( M, JJ )-RANK, N-RANK, K, $ A( RANK+1, RANK+1 ), LDA, C( 1, RANK+1 ), $ LDC, WORK( N+MN+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( 1 ) = ONE * DO 220 J = 2, RANK CALL DLAIC1( 1, J-1, WORK( 1 ), SMAX, $ A( 1, J ), A( J, J ), SMAXPR, SINE, COSINE ) CALL DSCAL( J-1, SINE, WORK( 1 ), 1 ) WORK( 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 DLAIC1( 1, RANK, WORK( 1 ), SMAX, $ A( 1, RANK+1 ), A( RANK+1, RANK+1 ), SMXRP1, $ SINE, COSINE ) CALL DLAIC1( 2, RANK, WORK( N+1 ), SMIN, $ A( 1, RANK+1 ), A( RANK+1, RANK+1 ), SMINPR, $ SINE, COSINE ) CALL DSCAL( RANK, SINE, WORK( N+1 ), 1 ) WORK( N+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 DLAIC1( 2, J-1, WORK( N+1 ), SMIN, $ A( 1, J ), A( J, J ), SMINPR, SINE, COSINE ) CALL DSCAL( J-1, SINE, WORK( N+1 ), 1 ) WORK( N+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 ) $ INFO = 1 END IF RETURN * * End of DTRQYC * END SHAR_EOF fi # end of overwriting check if test -f 'dtrrnk.f' then echo shar: will not over-write existing file "'dtrrnk.f'" else cat << SHAR_EOF > 'dtrrnk.f' SUBROUTINE DTRRNK( N, R, LDR, RCOND, RANK, WORK, INFO ) * * $Revision: 1.84 $ * $Date: 96/12/30 16:59:21 $ * * .. Scalar Arguments .. INTEGER LDR, N, RANK, INFO DOUBLE PRECISION RCOND * .. * .. Array Arguments .. DOUBLE PRECISION R( LDR, * ), WORK( * ) * * Purpose * ======= * * DTRRNK 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) DOUBLE PRECISION 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) 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 ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I DOUBLE PRECISION C1, C2, SMAX, SMAXPR, SMIN, SMINPR, S1, S2 * .. * .. External Subroutines .. EXTERNAL DLAIC1 * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. 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( 'DTRRNK', -INFO ) RETURN END IF * * Determine RANK using incremental condition estimation. * WORK( 1 ) = ONE WORK( N+1 ) = ONE 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 DLAIC1( 2, RANK, WORK, SMIN, R( 1, I ), $ R( I, I ), SMINPR, S1, C1 ) CALL DLAIC1( 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 DTRRNK * END SHAR_EOF fi # end of overwriting check if test -f 'dutils.f' then echo shar: will not over-write existing file "'dutils.f'" else cat << SHAR_EOF > 'dutils.f' * * 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.84 $ * $Date: 96/12/30 16:59:22 $ * ********************************************************************* INTEGER FUNCTION flXGEQPF( m, n ) INTEGER m, n * returns flop count for xgeqpf (lapack routine with column * pivoting) INTEGER tflops, i * initialize column norms tflops = 3*n+1 DO 10 i =1,min(m,n) * find pivot column and update partial column norms tflops = tflops + 10*(n-i) * compute HH vector tflops = tflops + 3*(m-i+1)+6 * update remaining submatrix tflops = tflops + 4*(m-i+1)*(n-i)+3*(n-i) 10 CONTINUE flXGEQPF = tflops RETURN END ********************************************************************* INTEGER FUNCTION flXGEQR2(m,n) INTEGER m, n * returns flop count for xgeqr2 (lapack blas 2 routine for * QR factorization without column exchanges) INTEGER i, tflops tflops = 0 DO 10 i =1,min(m,n) * compute HH vector tflops = tflops + 3*(m-i+1)+6 * update remaining submatrix tflops = tflops + 4*(m-i+1)*(n-i)+3*(n-i) 10 CONTINUE flXGEQR2 = tflops RETURN END ********************************************************************* INTEGER FUNCTION flXLARFT(m,nb) INTEGER m, nb * returns flop count for slarft (generation of a block * reflector) INTEGER i, tflops tflops = 0 DO 10 i = 2, nb * flops for DGEMV tflops = tflops + 2*(m-i+1)*(i-1)+2*(i-1) * flops for DTRMV tflops = tflops + (i-1)*(i-1)+2*(i-1) 10 CONTINUE flXLARFT = tflops RETURN END ********************************************************************* INTEGER FUNCTION flXLARFB(m,n,nb) INTEGER m, n, nb * returns flop count for applying a m by nb block reflector * from the left to a m by n matrix INTEGER t * XGEMM t = nb*(2*m*n + 2*n) * XTRMM t = t + n*nb*nb * XGEMM t = t + n*(2*m*nb+nb) flXLARFB = t RETURN END ******************************************************************* INTEGER FUNCTION flXGEQRF(m,n,nb) INTEGER m, n, nb * returns flop count for blocked QR factorization without * column exchanges INTEGER i, t, kb EXTERNAL flXGEQR2, flXLARFT, flXLARFB INTEGER flXGEQR2, flXLARFT, flXLARFB t = 0 DO 10 i = 1,min(m,n),nb kb = min(min(m,n)-i+1,nb) t = t + flXGEQR2(m-i+1,kb) $ + flXLARFT(m-i+1,kb) $ + flXLARFB(m-i+1,n-i-kb+1,kb) 10 CONTINUE flXGEQRF = t RETURN END ********************************************************************* SUBROUTINE DZLTRI( m, n, a, lda ) * zeroes lower triangle of m-by-n matrix A INTEGER m, n, lda DOUBLE PRECISION a( lda, n ) DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) INTEGER i, j DO 10 j = 1, n DO 20 i = j+1, m a(i,j) = ZERO 20 CONTINUE 10 CONTINUE RETURN END ********************************************************************* INTEGER FUNCTION flXLAIC1(j) INTEGER j * flops for incremental condition estimation excluding * construction of nullvector flXLAIC1 = 43 + 2*j RETURN END ********************************************************************* LOGICAL FUNCTION iscle(vname,var,bound) * INTEGER scalar 'var' less equal 'bound' ? CHARACTER*(*) vname INTEGER var, bound IF( ABS(var) .gt. bound) then WRITE(*,1000) vname,var,bound iscle = .false. ELSE iscle = .true. END IF RETURN 1000 FORMAT(/,1x,a,' = ',i6,' > bound = ',i6) END ********************************************************************* LOGICAL FUNCTION iarle(vname,var,length,bound) * INTEGER array 'var' less equal 'bound' ? CHARACTER*(*) vname INTEGER length, var(length), bound, i DO 10 i = 1,length IF( ABS(var(i)) .gt. bound) then WRITE(*,1000) vname,i,ABS(var(i)), bound iarle = .false. RETURN END IF 10 CONTINUE iarle = .true. RETURN 1000 FORMAT(/,1x,a,'(',i3,') = ',i6,' > bound = ',i6) END ********************************************************************* DOUBLE PRECISION FUNCTION Dckqrf( m, n, qt, ldqt, r, ldr, $ a, lda, jpvt, work ) INTEGER m,n,ldqt,ldr,lda DOUBLE PRECISION qt(ldqt,m),r(ldr,n),a(lda,n),work(m) INTEGER jpvt(n) * * This code computes the frobenius norm of Q'*A*P-R, * where permutation matrix P is defined by jpvt. * DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) EXTERNAL Dgemv, Dnrm2 DOUBLE PRECISION Dnrm2 INTRINSIC sqrt,min INTEGER i, j DOUBLE PRECISION aux aux = ZERO DO 10 j = 1, n * Store j-th column of R in vector work. DO 20 i = 1, min(m,j) work(i) = r(i,j) 20 CONTINUE DO 30 i = j+1, m work(i) = ZERO 30 CONTINUE * Substract j-th column of Q'*A*P and j-th column of R. CALL Dgemv('No transpose',m,m,-ONE,qt,ldqt,a(1,jpvt(j)),1, $ ONE,work,1) * Accumulate the residuals. aux = aux + Dnrm2(m,work,1) ** 2 10 CONTINUE Dckqrf = sqrt(aux) RETURN END ******************************************************************* DOUBLE PRECISION FUNCTION Dckort( m, n, q, ldq, work ) INTEGER m,n,ldq DOUBLE PRECISION q(ldq,n), work(n) * * Checks for orthogonality of matrix Q with orthogonal columns. * It computes the frobenius norm of Q'*Q-In, where Q is m by n, * Q' is the transpose of Q and In is n by n identity matrix. * DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) EXTERNAL Dgemv, Dnrm2 DOUBLE PRECISION Dnrm2 INTRINSIC sqrt INTEGER i,j DOUBLE PRECISION aux aux = ZERO DO 10 j = 1, n * Assign j-th column of In (n by n identity matrix) to vector work. DO 20 i = 1, n work(i) = ZERO 20 CONTINUE work(j) = ONE * Compute work:= work - Q'*Q(:,j). CALL Dgemv('Transpose',m,n,-ONE,q,ldq,q(1,j),1, $ ONE,work,1) * Accumulate the residuals. aux = aux + Dnrm2(n,work,1) ** 2 10 CONTINUE Dckort = sqrt(aux) RETURN END ******************************************************************* DOUBLE PRECISION FUNCTION Dcksvd( m, n, a, lda, svlues, $ work1,work2) INTEGER m, n, lda DOUBLE PRECISION a(lda,*), svlues(*),work1(m,*), $ work2(*) * * compares the singular values s of the upper triangle of A * with the values in svlues and returns * || s - svlues||/||svlues|| * DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) INTEGER i, j, info, mn DOUBLE PRECISION dummy, nrmsvl EXTERNAL Dgebd2, Dbdsqr, Daxpy, Dnrm2 DOUBLE PRECISION Dnrm2 mn = min( m, n ) nrmsvl = Dnrm2(mn,svlues,1) IF( nrmsvl .eq. ZERO) nrmsvl = ONE * * Copy upper triangle of A into work1 * DO 10 j = 1, n DO 20 i = 1, min( j, m ) work1( i, j ) = a( i, j ) 20 CONTINUE DO 30 i = j+1,m work1(i,j) = ZERO 30 CONTINUE 10 CONTINUE * * compute SVD of work1 * CALL Dgebd2(m,n,work1,m,work2(1),work2(mn+1),work2(2*mn+1), $ work2(3*mn+1),work2(4*mn+1),info) CALL Dbdsqr('upper',mn,0,0,0,work2(1),work2(mn+1),dummy,mn, $ dummy,1,dummy,mn,work1(1,1),info) * * compare svlues and work1 * CALL Daxpy(mn,-ONE,svlues,1,work2,1) Dcksvd = Dnrm2(mn,work2,1)/nrmsvl RETURN END ********************************************************************* DOUBLE PRECISION FUNCTION Dckpqr(m,n,k,qr,ldq,tau,a,lda, $ jpvt,work) INTEGER m,n,k,lda,ldq DOUBLE PRECISION qr(ldq,n),tau(n),a(lda,n),work(*) INTEGER jpvt(n) * * Let qr be the (possibly partial) QR-factorization of a matrix B, * i.e. the upper triangle of qr(1:k,1:k) is a partial triangular * factor and the entries below the diagonal in the first k columns * are the Householder vectors. The rest of qr contains a partially * updated matrix. * The vector tau contain the particulars of the Householder matrices. * jpvt contains the pivot inFORMATion * The required workspace is: m+n. * * This FUNCTION returns || Q'A*P - R|| * DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) INTEGER i, j, info DOUBLE PRECISION aux EXTERNAL Dorm2r, Dcopy, Dnrm2 DOUBLE PRECISION Dnrm2 INTRINSIC sqrt aux = ZERO DO 10 j = 1, n * Compute j-th column of Q'*A*P and put into vector work(1:m). CALL Dcopy( m,a(1,jpvt(j)),1,work(1),1) CALL Dorm2r( 'left','transpose', m, 1, k, qr, ldq, tau, $ work( 1 ), m, work( m+1 ), info ) * Substract j-th column of Q'*A*P and j-th column of R * (stored in qr). IF( j.gt.k ) then DO 20 i = 1, m work(i) = work(i) - qr(i,j) 20 CONTINUE ELSE DO 30 i = 1, j work(i) = work(i) - qr(i,j) 30 CONTINUE END IF aux = aux + Dnrm2(m,work,1) ** 2 10 CONTINUE Dckpqr = sqrt(aux) RETURN END ******************************************************************* LOGICAL FUNCTION find(which,an,lan) INTEGER which, lan, an(lan) * returns TRUE if 'which' is a value in 'an', FALSE otherwise. INTEGER i find = .false. DO 10 i = 1,lan IF( an(i) .eq. which) then find = .true. GOTO 20 END IF 10 CONTINUE 20 RETURN END ********************************************************************* SUBROUTINE iZERO(n,x) INTEGER n, x(n) * ZEROs an n-vector x INTEGER i DO 10 i = 1,n x(i) = 0 10 CONTINUE RETURN END ********************************************************************* SUBROUTINE icopy(n,a,b) INTEGER n, a(n), b(n) * copies vector a into vector b INTEGER i DO 10 i = 1,n b(i) = a(i) 10 CONTINUE RETURN END ********************************************************************* INTEGER FUNCTION SFRANK(S,N,RCOND) INTEGER N DOUBLE PRECISION S(N), RCOND * * returns MAX { 1 <= i <= n | s(1)/s(i) < 1/RCOND } * The entries of S are assumed to be nonnegative and * monotoniCALLy decreasing. * INTEGER I SFRANK = 1 DO 10 I = N,2,-1 IF( S( 1 )*RCOND.LT.S( I ) ) THEN SFRANK = I GOTO 20 END IF 10 CONTINUE 20 RETURN * * END OF SFRANK * END ********************************************************************* SUBROUTINE Dsort(n,x,incrx,job) INTEGER n, incrx CHARACTER*1 job DOUBLE PRECISION x(*) * * SUBROUTINE to sort a vector * * On entry: * ======== * * x vector of length n to be sorted * n length of vector * incrx element spacing in x * job = 'i' or 'i' sorts in increasing order * = 'd' or 'd' sorts in decreasing order * otherwise the routine returns without performing * any computation * * On exit: * ======== * * x sorted in the prescribed order * * * EXTERNAL entries * ================ * LOGICAL lsame EXTERNAL lsame * * internal variables * ================== * INTEGER i, curelt, nextelt, switch,k DOUBLE PRECISION temp switch = 0 IF( lsame(job,'i')) switch = 1 IF( lsame(job,'d')) switch = 2 IF( switch .eq. 0) RETURN GOTO (100,200) switch * * sort in increasing order * 100 DO 10 i = n-1,1,-1 k = i 20 IF( k .eq. n) GOTO 10 curelt = 1+(k-1)*incrx nextelt = 1 + k*incrx IF( x(curelt) .le. x(nextelt)) then GOTO 10 ELSE temp = x(curelt) x(curelt) = x(nextelt) x(nextelt) = temp END IF k = k+1 GOTO 20 10 CONTINUE RETURN * * sort in decreasing order * 200 DO 30 i = n-1,1,-1 k = i 40 IF( k .eq. n) GOTO 30 curelt = 1+(k-1)*incrx nextelt = 1 + k*incrx IF( x(curelt) .ge. x(nextelt)) then GOTO 30 ELSE temp = x(curelt) x(curelt) = x(nextelt) x(nextelt) = temp END IF k = k+1 GOTO 40 30 CONTINUE RETURN * * next line is last line of SUBROUTINE Dsort END ********************************************************************* SUBROUTINE isort(n,ix,job) INTEGER n CHARACTER*1 job INTEGER ix(*) * * SUBROUTINE to sort a vector of INTEGERs * * On entry: * ======== * * ix vector of length n to be sorted * n length of vector * job = 'i' or 'i' sorts in increasing order * = 'd' or 'd' sorts in decreasing order * otherwise the routine returns without performing * any computation * * On exit: * ======== * * ix sorted in the prescribed order * * EXTERNALs: * ========= * LOGICAL lsame EXTERNAL lsame * * internal variables * ================== * INTEGER i, curelt, nextelt, switch, k, temp switch = 0 IF( lsame(job,'i')) switch = 1 IF( lsame(job,'d')) switch = 2 IF( switch .eq. 0) RETURN GOTO (100,200) switch * * sort in increasing order * 100 DO 10 i = n-1,1,-1 k = i 20 IF( k .eq. n) GOTO 10 curelt = 1+(k-1) nextelt = 1 + k IF( ix(curelt) .le. ix(nextelt)) then GOTO 10 ELSE temp = ix(curelt) ix(curelt) = ix(nextelt) ix(nextelt) = temp END IF k = k+1 GOTO 20 10 CONTINUE RETURN * * sort in decreasing order * 200 DO 30 i = n-1,1,-1 k = i 40 IF( k .eq. n) GOTO 30 curelt = 1+(k-1) nextelt = 1 + k IF( ix(curelt) .ge. ix(nextelt)) then GOTO 30 ELSE temp = ix(curelt) ix(curelt) = ix(nextelt) ix(nextelt) = temp END IF k = k+1 GOTO 40 30 CONTINUE RETURN * * next line is last line of SUBROUTINE isort END ********************************************************************* SUBROUTINE Dqrdc(x,ldx,n,p,qraux,jpvt,work,job) INTEGER ldx,n,p,job INTEGER jpvt(p) DOUBLE PRECISION x(ldx,p),qraux(p),work(p) c c sqrdc uses householder transFORMATions to compute the qr c factorization of an n by p matrix x. column pivoting c based on the 2-norms of the reduced columns may be c performed at the users option. c c On entry c c x DOUBLE PRECISION(ldx,p), where ldx .ge. n. c x contains the matrix whose decomposition is to be c computed. c c ldx INTEGER. c ldx is the leading dimension of the array x. c c n INTEGER. c n is the number of rows of the matrix x. c c p INTEGER. c p is the number of columns of the matrix x. c c jpvt INTEGER(p). c jpvt contains INTEGERs that control the selection c of the pivot columns. the k-th column x(k) of x c is placed in ONE of three classes according to the c value of jpvt(k). c c if jpvt(k) .gt. 0, then x(k) is an initial c column. c c if jpvt(k) .eq. 0, then x(k) is a free column. c c if jpvt(k) .lt. 0, then x(k) is a final column. c c before the decomposition is computed, initial columns c are moved to the beginning of the array x and final c columns to the END. both initial and final columns c are frozen in place during the computation and only c free columns are moved. at the k-th stage of the c reduction, if x(k) is occupied by a free column c it is interchanged with the free column of largest c reduced norm. jpvt is not referenced if c job .eq. 0. c c work DOUBLE PRECISION(p). c work is a work array. work is not referenced if c job .eq. 0. c c job INTEGER. c job is an INTEGER that initiates column pivoting. c if job .eq. 0, no pivoting is DOne. c if job .ne. 0, pivoting is DOne. c c On RETURN c c x x contains in its upper triangle the upper c triangular matrix r of the qr factorization. c below its diagonal x contains inFORMATion from c which the orthogonal part of the decomposition c can be recovered. note that if pivoting has c been requested, the decomposition is not that c of the original matrix x but that of x c with its columns permuted as described by jpvt. c c qraux DOUBLE PRECISION(p). c qraux contains further inFORMATion required to recover c the orthogonal part of the decomposition. c c jpvt jpvt(k) contains the index of the column of the c original matrix that has been interchanged into c the k-th column, if pivoting was requested. c c linpack. this version dated 08/14/78 . c g.w. stewart, university of maryland, argonne national lab. c c sqrdc uses the following functions and subprograms. c c blas saxpy,sDOt,sscal,sswap,snrm2 c fortran ABS,MAX,min0,sqrt c c internal variables c DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) c INTEGER j,jp,l,lp1,lup,maxj,pl,pu,jj DOUBLE PRECISION maxnrm,Dnrm2,tt DOUBLE PRECISION DDOt,nrmxl,t LOGICAL negj,swapj c c pl = 1 pu = 0 IF( job .eq. 0) GOTO 60 c c pivoting has been requested. rearrange the columns c according to jpvt. c DO 20 j = 1, p swapj = jpvt(j) .gt. 0 negj = jpvt(j) .lt. 0 jpvt(j) = j IF( negj) jpvt(j) = -j IF( .not.swapj) GOTO 10 IF( j .ne. pl) CALL Dswap(n,x(1,pl),1,x(1,j),1) jpvt(j) = jpvt(pl) jpvt(pl) = j pl = pl + 1 10 CONTINUE 20 CONTINUE pu = p DO 50 jj = 1, p j = p - jj + 1 IF( jpvt(j) .ge. 0) GOTO 40 jpvt(j) = -jpvt(j) IF( j .eq. pu) GOTO 30 CALL Dswap(n,x(1,pu),1,x(1,j),1) jp = jpvt(pu) jpvt(pu) = jpvt(j) jpvt(j) = jp 30 CONTINUE pu = pu - 1 40 CONTINUE 50 CONTINUE 60 CONTINUE c c compute the norms of the free columns. c IF( pu .lt. pl) GOTO 80 DO 70 j = pl, pu qraux(j) = Dnrm2(n,x(1,j),1) work(j) = qraux(j) 70 CONTINUE 80 CONTINUE c c perform the householder reduction of x. c lup = min0(n,p) DO 200 l = 1, lup IF( l .lt. pl .or. l .ge. pu) GOTO 120 c c locate the column of largest norm and bring it c into the pivot position. c maxnrm = 0.0 maxj = l DO 100 j = l, pu IF( qraux(j) .le. maxnrm) GOTO 90 maxnrm = qraux(j) maxj = j 90 CONTINUE 100 CONTINUE IF( maxj .eq. l) GOTO 110 CALL Dswap(n,x(1,l),1,x(1,maxj),1) qraux(maxj) = qraux(l) work(maxj) = work(l) jp = jpvt(maxj) jpvt(maxj) = jpvt(l) jpvt(l) = jp 110 CONTINUE 120 CONTINUE qraux(l) = ZERO IF( l .eq. n) GOTO 190 c c compute the householder transFORMATion for column l. c nrmxl = Dnrm2(n-l+1,x(l,l),1) IF( nrmxl .eq. ZERO) GOTO 180 IF( x(l,l) .ne. ZERO) nrmxl = sign(nrmxl,x(l,l)) CALL Dscal(n-l+1,ONE/nrmxl,x(l,l),1) x(l,l) = ONE + x(l,l) c c apply the transFORMATion to the remaining columns, c updating the norms. c lp1 = l + 1 IF( p .lt. lp1) GOTO 170 DO 160 j = lp1, p t = - DDOT(n-l+1,x(l,l),1,x(l,j),1)/x(l,l) CALL Daxpy(n-l+1,t,x(l,l),1,x(l,j),1) IF( j .lt. pl .or. j .gt. pu) GOTO 150 IF( qraux(j) .eq. ZERO) GOTO 150 tt = ONE - (ABS(x(l,j))/qraux(j))**2 tt = MAX(tt,ZERO) t = tt tt = ONE + 0.05*tt*(qraux(j)/work(j))**2 IF( tt .eq. ONE) GOTO 130 qraux(j) = qraux(j)*sqrt(t) GOTO 140 130 CONTINUE qraux(j) = Dnrm2(n-l,x(l+1,j),1) work(j) = qraux(j) 140 CONTINUE 150 CONTINUE 160 CONTINUE 170 CONTINUE c c save the transFORMATion. c qraux(l) = x(l,l) x(l,l) = -nrmxl 180 CONTINUE 190 CONTINUE 200 CONTINUE RETURN END ********************************************************************** SHAR_EOF fi # end of overwriting check if test -f 'esm.f' then echo shar: will not over-write existing file "'esm.f'" else cat << SHAR_EOF > 'esm.f' c *---------------------------------------------------------------* c i i c i entrada/salida matricial i c i i c *---------------------------------------------------------------* c ***************************************************************** c * escmatriz * c ***************************************************************** c * esta subrutina escribe en la salida estandar una matriz de * c * dimension m x n cuyos componentes son reales en simple * c * precision. se escribe cada elemento en una linea. * c ***************************************************************** subroutine escmatriz (a,lda,m,n) integer lda integer m,n real a(lda,n) integer f,c do f=1,m do c=1,n print *,' a(',f,' , ',c,' ) : ',a(f,c) end do end do return end c ***************************************************************** c * escmaf * c ***************************************************************** c * esta subrutina escribe en la salida estandar una matriz de * c * dimension m x n cuyos componentes son reales en simple * c * precision. todos los elementos de una fila se escriben en * c * una misma fila de pantalla, si caben. * c ***************************************************************** subroutine escmaf (a,lda,m,n) integer lda integer m,n real a(lda,n) integer f,c do f=1,m WRITE (*,10) (a(f,c), c=1,n) 10 format (1x, 100(e12.5)) end do return end c ***************************************************************** c * escvector * c ***************************************************************** c * esta subrutina escribe en la salida estandar un vector de * c * n numeros reales en simple precision, situando uno en cada * c * linea. * c ***************************************************************** subroutine escvector (v,n) integer n real v(n) integer f do f=1,n print *,'el elemento v( ',f,' ) es: ',v(f) end do return end c ***************************************************************** c * escvef * c ***************************************************************** c * esta subrutina escribe en la salida estandar un vector de * c * n numeros reales en simple precision. en este caso se situan * c * todos los elementos en una sola linea. * c ***************************************************************** subroutine escvef (v,n) integer n real v(n) integer f WRITE (*,10) (v(f), f=1,n) 10 format (1x, 100(e12.5)) return end c ***************************************************************** c * escvint * c ***************************************************************** c * esta subrutina escribe en la salida estandar un vector de * c * n numeros enteros, situando uno en cada linea. * c ***************************************************************** subroutine escvint (v,n) integer n integer v(n) integer f do f=1,n print *,'el elemento v( ',f,' ) es: ',v(f) end do return end c ***************************************************************** c * escvif * c ***************************************************************** c * esta subrutina escribe en la salida estandar un vector de * c * n numeros reales en simple precision. en este caso se situan * c * todos los elementos en una sola linea. * c ***************************************************************** subroutine escvif (v,n) integer n integer v(n) integer f WRITE (*,10) (v(f), f=1,n) 10 format (1x, 100(i8)) return end c ***************************************************************** c * espera * c ***************************************************************** c * esta subrutina lee un caracter del teclado, para lo cual * c * detiene momentaneamente la ejecucion del programa. * c ***************************************************************** subroutine espera character*1 c read (*,10) c 10 format (a1) return end c ***************************************************************** c * leed * c ***************************************************************** c * esta subrutina lee un entero de la entrada estandar * c * comprendido entre 1 y "max". si el numero tecleado no esta * c * dentro de este rango, se vuelve a demandar otro. * c ***************************************************************** subroutine leed ( max,n ) integer max,n n = 0 do while ( (n .lt. 1) .or. (n .gt. max) ) print *,'dame un numero 1 .. ',max,' : ' read (*,*) n end do return end SHAR_EOF fi # end of overwriting check if test -f 'ilaenv.f' then echo shar: will not over-write existing file "'ilaenv.f'" else cat << SHAR_EOF > 'ilaenv.f' INTEGER FUNCTION ILAENV( ISPEC, SUBNAM, OPTS, N1, N2, N3, $ N4 ) * * -- LAPACK auxiliary routine (preliminary version) -- * Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, * Courant Institute, NAG Ltd., and Rice University * August 17, 1990 * * ** TEST VERSION ** * * .. Scalar Arguments .. CHARACTER*( * ) OPTS, SUBNAM INTEGER ISPEC, N1, N2, N3, N4 * .. * * Purpose * ======= * * ILAENV returns machine and problem-dependent parameters. * * Arguments * ========= * * ISPEC (input) INTEGER * Specifies what quantity is to be returned (as the function's * value): * = 1: The optimum blocksize. ILAENV(1,...)=1 is a flag that * no blocking should be done. * = 2: The minimum blocksize. * = 3: The "crossover point". When two versions of a solution * method are implemented, one of which is faster for * problems and the other faster for smaller problems, * this is the largest problem for which the small-problem * method is preferred. * = 4: the number of shifts to use. At present, this is only * appropriate for the nonsymmetric eigenvalue and * generalized eigenvalue routines, and -1 will be returned * if SUBNAM(2:6) is not 'HSEQR' or 'HGEQZ'. * = 5: The minimum second dimension for blocked updates. This * is primarily intended for methods which update * rectangular blocks using Householder transformations * with short Householder vectors (e.g., xLAEBC and * xLAGBC). If a k x k Householder transformation is * used to update a k x m block, then blocking (i.e., * use of xGEMM) will only be done if k is at least * ILAENV(2,...) and m is at least ILAENV(5,...) * = 6: (Used only by the SVD drivers.) When reducing an m x n * matrix to bidiagonal form, if the larger dimension is * less than ILAENV(6,...,m,n,,), then the usual procedure * is preferred. If the larger dimension is larger than * ILAENV(6,...,m,n,,), then it is preferred to first use * a QR (or LQ) factorization to make it triangular, and * then reduce it to bidiagonal form. * * = 7: Number of processors. * * SUBNAM (input) CHARACTER*(*) * The name of the calling routine, or the routine which is * expected to use the value returned. * * OPTS (input) CHARACTER*(*) * The values of the CHARACTER*1 options passed to the routine * whose name is in SUBNAM, all run together. For example, * a subroutine called with "CALL SGEZZZ('T','Y',N4,'C',A,LDA)" * would pass 'SGEZZZ' as SUBNAM and 'TYC' as OPTS. * * N1,N2,N3,N4 (input) INTEGER * The problem dimensions, in the order that they appear in * the calling sequence. If there is only one dimension * (customarily called N), then that value should be passed * as N1 and N2, N3, and N4 will be ignored, etc. * * (ILAENV) (output) INTEGER * The function value returned will be the value specified * by ISPEC. If no reasonable value is available, a negative * value will be returned, otherwise the returned value will * be non-negative. Note that the value returned may be * unreasonably large for the problem, e.g., a blocksize of * 32 for an 8 x 8 problem, and thus should be restricted * to whatever range is appropriate. * * Further Details * ======= ======= * * The calling sequence is intended to match up to the arguments of * the routine needing the value in a simple and mindless way. * For example, if SGEZZZ were defined as * * SUBROUTINE SGEZZZ( OPT1, OPT2, N4, OPT3, N1, A, LDA ) * CHARACTER*1 OPT1, OPT2, OPT3 * INTEGER N1, LDA, N4 * REAL A(LDA,*) * * then in SGEZZ, the blocksize would be found by a call like: * * NBLOCK = ILAENV( 1, 'SGEZZZ', OPT1//OPT2//OPT3, N4, N1, 0, 0 ) * * It would be further checked and restricted by code like the * following: * * NBLOCK = MAX( 1, MIN( N4, NBLOCK ) ) * IF( NBLOCK.EQ.1 ) THEN * c * c unblocked method * c * . . . * *======================================================================= * * .. Local Scalars .. CHARACTER NAME1 CHARACTER*2 NAME23 CHARACTER*3 NAME46 CHARACTER*6 NAMWRK * .. * .. Intrinsic Functions .. INTRINSIC INT, MAX, REAL * .. * .. Arrays in Common .. INTEGER NENVIR( 10 ) * .. * .. Common blocks .. COMMON / CENVIR / NENVIR * .. * .. Save statement .. SAVE / CENVIR / * .. * .. Executable Statements .. * * ISPEC > 7 or ISPEC < 1: Error (return -1) * IF( ISPEC.LT.1 .OR. ISPEC.GT.7 ) THEN ILAENV = -1 RETURN END IF * * ISPEC=7: Number of processors * IF( ISPEC.EQ.7 ) THEN ILAENV = MAX( 1, NENVIR( 7 ) ) RETURN END IF * * ISPEC=6: Jim's crossover. * IF( ISPEC.EQ.6 ) THEN ILAENV = INT( REAL( MAX( N1, N2 ) )*1.6E0 ) RETURN END IF * * ISPEC=1 through ISPEC=6: split up name into components * NAMWRK = SUBNAM NAME1 = NAMWRK( 1: 1 ) NAME23 = NAMWRK( 2: 3 ) NAME46 = NAMWRK( 4: 6 ) * * Test version: just use number from common block * ILAENV = MAX( 0, NENVIR( ISPEC ) ) RETURN * * End of ILAENV * END SHAR_EOF fi # end of overwriting check if test -f 'sgeqpb.f' then echo shar: will not over-write existing file "'sgeqpb.f'" else cat << SHAR_EOF > 'sgeqpb.f' SUBROUTINE SGEQPB( JOB, M, N, K, A, LDA, C, LDC, JPVT, IRCOND, $ ORCOND, RANK, SVLUES, WORK, LWORK, 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.84 $ * $Date: 96/12/30 16:59:10 $ * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, RANK, LWORK, INFO REAL IRCOND, ORCOND * .. * .. Array Arguments .. INTEGER JPVT( * ) REAL A( LDA, * ), C( LDC, * ), WORK( * ), $ SVLUES( 4 ) * .. * * Purpose * ======= * * SGEQPB 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 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. 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) REAL 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) REAL array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the orthogonal 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) REAL * 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) REAL * 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) REAL 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+3*N. * The block algorithm requires that: * LWORK >= 2*MN+N*NB. * If JOB<>1: * The unblocked strategy requires that: * LWORK >= 2*MN+2*N+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 xORMQR. * In both cases, the minimum required workspace is the * one for the unblocked strategy. * * INFO (output) INTEGER * = 0: Successful exit * < 0: If INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 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, SGEQPW, SGEQPC, $ SLARFT, SLARFB * .. * .. 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 workspace size. * IF( JOB.EQ.1 ) THEN WKMIN = 2*MN + 3*N ELSE WKMIN = 2*MN + 2*N + 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 ) ) THEN * * Compute the optimal workspace size. * IF( JOB.EQ.1 ) THEN NB = ILAENV( INB, 'SGEQRF', ' ', M, N, 0, 0 ) WSIZE = 2*MN + MAX( 3*N, N*NB ) ELSE NB = MAX( ILAENV( INB, 'SGEQRF', ' ', M, N, 0, 0 ), $ ILAENV( INB, 'SORMQR', ' ', M, N, 0, 0 ) ) WSIZE = MAX( 2*MN + 2*N + 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( 'SGEQPB', -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 the allowed block size for the given workspace * 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, 'SGEQRF', ' ', M, N, 0, 0 ) ).AND. $ ( MN.GE.ILAENV( IXOVER, 'SGEQRF', ' ', 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 SGEQPC( 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 ) 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 SGEQPW( M, LWSIZE, KB, KK-1, LACPTD, A, LDA, $ JPVT, RCOND, WORK( MN+1 ), SMIN, MXNM, $ WORK( 1 ), WORK( 2*MN+1 ) ) IF( LACPTD.GT.0 ) THEN * * Accumulate Householder vectors in a block reflector. * CALL SLARFT( '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 SLARFB( 'Left', '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 SLARFB( 'Left', '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 SLARFB( '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 SSWAP( 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 SGEQPC( 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 ) RANK = ACCPTD + LACPTD ELSE RANK = ACCPTD SVLUES( IAFTER ) = SMIN SVLUES( IMIN ) = SMIN END IF ELSE * * *-*-*-*-*-*-*-*-*-*-*-*-* * * using unblocked code * * *-*-*-*-*-*-*-*-*-*-*-*-* * ACCPTD = 1 CALL SGEQPC( 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 ) 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 ) = ZERO 60 CONTINUE 50 CONTINUE * WORK( 1 ) = REAL( WSIZE ) RETURN * * End of SGEQPB * END SHAR_EOF fi # end of overwriting check if test -f 'sgeqpc.f' then echo shar: will not over-write existing file "'sgeqpc.f'" else cat << SHAR_EOF > 'sgeqpc.f' SUBROUTINE SGEQPC( JOB, M, N, K, A, LDA, C, LDC, DSRD, OFFSET, $ IRCOND, LACPTD, JPVT, TAU, X, SVLUES, MXNM, $ WORK, LWORK ) * * 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.84 $ * $Date: 96/12/30 16:59:11 $ * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, DSRD, OFFSET, LACPTD, $ LWORK REAL IRCOND, MXNM * .. * .. Array Arguments .. INTEGER JPVT( * ) REAL A( LDA, * ), C( LDC, * ), TAU( * ), $ WORK( * ), X( * ), SVLUES( 4 ) * .. * * Purpose: * ======= * * SGEQPC continues a partial QR factorization of A. If * A(1:OFFSET,1:OFFSET) has been reduced to upper triangular * form, then SGEQPC 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 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. 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) REAL 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) REAL array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the orthogonal 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) REAL array, dimension (MIN(M,N)) * Further details of the orthogonal matrix Q (see A). * * X (input/output) REAL 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) * The estimates of the 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) REAL * 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) REAL array, dimension (LWORK) * * LWORK (input) INTEGER * MAX( 1, 3*N, N*NB ) if JOB=1, or * MAX( 1, 2*N + MAX( N, K ), MAX( N, K)*NB ) otherwise. * where NB is the maximum of blocksize used within xGEQRF and * blocksize used within xORMQR. * * 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 real scalar, and v is a real 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 ) * * 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 AII, TEMP, TEMP2, SMIN, SMINPR, SMAX, SMAXPR, $ SINE, COSINE * .. * .. External Subroutines .. EXTERNAL SLARFG, SLARF, SSWAP, SSCAL, $ SLAIC1, SORMQR, SGEQRF * .. * .. External Functions .. EXTERNAL ISAMAX, SNRM2, SLASMX, SLAUC1 INTEGER ISAMAX REAL SNRM2, SLASMX LOGICAL SLAUC1 * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. 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 WORK( I ) = SNRM2( M-OFFSET, A( OFFSET+1, I ), 1 ) WORK( N+I ) = WORK( 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, WORK( I ), 1 ) IF( PVT.NE.I ) THEN CALL SSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 ) ITEMP = JPVT( PVT ) JPVT( PVT ) = JPVT( I ) JPVT( I ) = ITEMP WORK( PVT ) = WORK( I ) WORK( N+PVT ) = WORK( N+I ) END IF * * Generate elementary reflector H(i). * IF( I.LT.M ) THEN CALL SLARFG( M-I+1, A( I, I ), A( I+1, I ), 1, $ TAU( I ) ) ELSE CALL SLARFG( 1, A( M, M ), A( M, M ), 1, TAU( M ) ) END IF * * Apply elementary reflector H(I) to the corresponding block * of matrices A and C. * AII = A( I, I ) A( I, I ) = ONE IF( I.LT.N ) THEN * * Apply H(I) to A(I:M,I+1:N) from the left. * CALL SLARF( 'Left', M-I+1, N-I, A( I, I ), 1, $ TAU( I ), A( I, I+1 ), LDA, WORK( 2*N+1 ) ) END IF IF( ( JOB.EQ.2 ).AND.( K.GT.0 ) ) THEN * * Apply H(I) to C(I:M,1:K) from the left. * CALL SLARF( 'Left', M-I+1, K, A( I, I ), 1, TAU( I ), $ C( I, 1 ), LDC, WORK( 2*N+1 ) ) 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 SLARF( 'Right', K, M-I+1, A( I, I ), 1, TAU( I ), $ C( 1, I ), LDC, WORK( 2*N+1 ) ) END IF A( I, I ) = AII * * Update partial column norms. * IF( I.LT.LASTI ) THEN DO 30 J = I+1, N IF( WORK( J ).NE.ZERO ) THEN TEMP = ONE-( ABS( A( I, J ) )/WORK( J ) )**2 TEMP = MAX( TEMP, ZERO ) TEMP2 = ONE+0.05*TEMP*( WORK( J )/WORK( N+J ) )**2 IF( TEMP2.EQ.ONE ) THEN WORK( J ) = SNRM2( M-I, A( I+1, J ), 1 ) WORK( N+J ) = WORK( J ) ELSE WORK( J ) = WORK( 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 ) = ONE IF( MXNM.GT.ZERO ) THEN LACPTD = 1 ELSE SVLUES( IAFTER ) = SMIN GOTO 50 END IF ELSE SMAXPR = SLASMX( I )*MXNM IF( SLAUC1( 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 SGEQRF( M-I, N-I, A( I+1, I+1 ), LDA, TAU( I+1 ), $ WORK, LWORK, INFO ) * * Apply the transformations computed in SGEQRF 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 SORMQR( 'Left', '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 SORMQR( '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 SLAIC1( 2, I-1, X, SMIN, A( 1, I ), A( I, I ), $ SMINPR, SINE, COSINE ) CALL SSCAL( 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 SGEQPC * END SHAR_EOF fi # end of overwriting check if test -f 'sgeqpw.f' then echo shar: will not over-write existing file "'sgeqpw.f'" else cat << SHAR_EOF > 'sgeqpw.f' SUBROUTINE SGEQPW( M, LWSIZE, NB, OFFSET, LACPTD, A, LDA, $ JPVT, IRCOND, X, SMIN, MXNM, TAU, WORK ) * * 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.84 $ * $Date: 96/12/30 16:59:12 $ * * .. Scalar Arguments .. INTEGER M, LWSIZE, NB, OFFSET, LACPTD, LDA REAL IRCOND, SMIN, MXNM * .. * .. Array Arguments .. INTEGER JPVT( * ) REAL A( LDA, * ), TAU( * ), X( * ), WORK( * ) * * * Purpose * ======= * * SGEQPW applies one block step of the Householder QR factorization * algorithm with restricted pivoting. It is called by SGEQPB. * * 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 SGEQP2 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 SGEQPB. * * 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) REAL 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 orthogonal * 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 orthogonal 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) REAL 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) REAL * The norm of the largest column in matrix A. * * TAU (output) REAL array, dimension (OFFSET+LWSIZE) * On exit, TAU(1:OFFSET+LACPTD) contains details of * the orthogonal matrix Q2. * * WORK (workspace) REAL array, dimension (3*LWSIZE) * * ================================================================ * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. INTEGER I, K, I1, LASTK, PVTIDX REAL GAMMA, AKK, TEMP, TEMP2, SMAX * .. * .. External Subroutines .. EXTERNAL SNRM2, SSCAL, SSWAP, SLARFG, $ SLARF, ISAMAX, SLAUC1, SLAPY2, $ SLASMX INTEGER ISAMAX REAL SNRM2, SLAPY2, SLASMX LOGICAL SLAUC1 * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. 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 WORK( I ) = SNRM2( M-OFFSET, A( OFFSET+1, OFFSET+I ), 1 ) WORK( LWSIZE+I ) = WORK( 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, WORK( LACPTD+1 ), 1 ) K = OFFSET + LACPTD + 1 * * Exchange current column and pivot column. * IF( PVTIDX.NE.K ) THEN CALL SSWAP( M, A( 1, PVTIDX ), 1, A( 1, K ), 1 ) I1 = JPVT( PVTIDX ) JPVT( PVTIDX ) = JPVT( K ) JPVT( K ) = I1 TEMP = WORK( PVTIDX-OFFSET ) WORK( PVTIDX-OFFSET ) = WORK( K-OFFSET ) WORK( K-OFFSET ) = TEMP TEMP = WORK( PVTIDX-OFFSET+LWSIZE ) WORK( PVTIDX-OFFSET+LWSIZE ) = WORK( K+LWSIZE-OFFSET ) WORK( K+LWSIZE-OFFSET ) = TEMP END IF * * Determine (offset+lacptd+1)st diagonal element GAMMA of * matrix A if elementary reflector were applied. * IF( A( K, K ).EQ.ZERO ) THEN GAMMA = -WORK( K-OFFSET ) ELSE GAMMA = -SIGN( WORK( K-OFFSET ), A( K, K ) ) END IF * * Update estimate for largest singular value. * SMAX = SLASMX( K )*MXNM * * Is candidate pivot column acceptable ? * ===================================== * IF( SLAUC1( 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 SLARFG( M-K+1, A( K, K ), A( K+1, K ), 1, $ TAU( K ) ) ELSE CALL SLARFG( 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 ) = ONE CALL SLARF( 'Left', M-K+1, LWSIZE-LACPTD, $ A( K, K ), 1, TAU( K ), A( K, K+1 ), LDA, $ WORK( 2*LWSIZE+1 ) ) A( K, K ) = AKK END IF * * Update partial column norms. * IF( K.LT.LASTK ) THEN DO 20 I = LACPTD+1,LWSIZE IF( WORK( I ).NE.ZERO ) THEN TEMP = ONE-( ABS( A( K, OFFSET+I ) )/WORK( I ) )**2 TEMP = MAX( TEMP, ZERO ) TEMP2 = ONE+ $ 0.05*TEMP*( WORK( I )/WORK( I+LWSIZE ) )**2 IF( TEMP2.EQ.ONE ) THEN WORK( I ) = $ SNRM2( M-K, A( K+1, OFFSET+I ), 1 ) WORK( I+LWSIZE ) = WORK( I ) ELSE WORK( I ) = WORK( 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 SGEQPW * END SHAR_EOF fi # end of overwriting check if test -f 'sgeqpx.f' then echo shar: will not over-write existing file "'sgeqpx.f'" else cat << SHAR_EOF > 'sgeqpx.f' SUBROUTINE SGEQPX( JOB, M, N, K, A, LDA, C, LDC, JPVT, IRCOND, $ ORCOND, RANK, SVLUES, WORK, LWORK, 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.84 $ * $Date: 96/12/30 16:59:13 $ * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, RANK, LWORK, INFO REAL IRCOND, ORCOND * .. * .. Array Arguments .. INTEGER JPVT( * ) REAL A( LDA, * ), C( LDC, * ), $ WORK( * ), SVLUES( 4 ) * .. * * Purpose * ======= * * SGEQPX 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 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. 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) REAL 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) REAL array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the orthogonal 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) REAL * 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) REAL * 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) 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) REAL 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+3*N. * The block algorithm requires that: * LWORK >= 2*MN+N*NB. * If JOB<>1: * The unblocked strategy requires that: * LWORK >= 2*MN+2*N+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. * * 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, SGEQPB, STRQPX * .. * .. Intrinsic Functions .. INTRINSIC MIN, MAX * .. * .. Local Scalars .. REAL WSIZE INTEGER MN, WKMIN * .. * .. Executable Statements .. * MN = MIN( M, N ) IF( JOB.EQ.1 ) THEN WKMIN = 2*MN+3*N ELSE WKMIN = 2*MN+2*N+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( 'SGEQPX',-INFO ) RETURN END IF * * Preprocessing * ============= * CALL SGEQPB( JOB, M, N, K, A, LDA, C, LDC, JPVT, IRCOND, $ ORCOND, RANK, SVLUES, WORK, LWORK, INFO ) WSIZE = WORK( 1 ) * * Postprocessing * ============== * IF( RANK.GT.0 ) THEN CALL STRQPX( JOB, M, N, K, A, LDA, C, LDC, JPVT, IRCOND, $ ORCOND, RANK, SVLUES, WORK, LWORK, INFO ) END IF * WORK( 1 ) = WSIZE RETURN * * End of SGEQPX * END SHAR_EOF fi # end of overwriting check if test -f 'sgeqpy.f' then echo shar: will not over-write existing file "'sgeqpy.f'" else cat << SHAR_EOF > 'sgeqpy.f' SUBROUTINE SGEQPY( JOB, M, N, K, A, LDA, C, LDC, JPVT, IRCOND, $ ORCOND, RANK, SVLUES, WORK, LWORK, 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.84 $ * $Date: 96/12/30 16:59:14 $ * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, RANK, LWORK, INFO REAL IRCOND, ORCOND * .. * .. Array Arguments .. INTEGER JPVT( * ) REAL A( LDA, * ), C( LDC, * ), $ WORK( * ), SVLUES( 4 ) * .. * * Purpose * ======= * * SGEQPY 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 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. 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) REAL 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) REAL array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the orthogonal 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) REAL * 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) REAL * 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) 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) REAL 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+3*N. * The block algorithm requires that: * LWORK >= 2*MN+N*NB. * If JOB<>1: * The unblocked strategy requires that: * LWORK >= 2*MN+2*N+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. * * 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, SGEQPB, STRQPY * .. * .. Intrinsic Functions .. INTRINSIC MIN, MAX * .. * .. Local Scalars .. REAL WSIZE INTEGER MN, WKMIN * .. * .. Executable Statements .. * MN = MIN( M, N ) IF( JOB.EQ.1 ) THEN WKMIN = 2*MN+3*N ELSE WKMIN = 2*MN+2*N+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( 'SGEQPY',-INFO ) RETURN END IF * * Preprocessing * ============= * CALL SGEQPB( JOB, M, N, K, A, LDA, C, LDC, JPVT, IRCOND, $ ORCOND, RANK, SVLUES, WORK, LWORK, INFO ) WSIZE = WORK( 1 ) * * Postprocessing * ============== * IF( RANK.GT.0 ) THEN CALL STRQPY( JOB, M, N, K, A, LDA, C, LDC, JPVT, IRCOND, $ ORCOND, RANK, SVLUES, WORK, LWORK, INFO ) END IF * WORK( 1 ) = WSIZE RETURN * * End of SGEQPY * END SHAR_EOF fi # end of overwriting check if test -f 'sgntst.f' then echo shar: will not over-write existing file "'sgntst.f'" else cat << SHAR_EOF > 'sgntst.f' SUBROUTINE SGNTST( WHICH, M, N, RTHRESH, GAP, STRIP, ISEED, $ RANK, S, A, LDA, WORK ) * * 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.84 $ * $Date: 96/12/30 16:59:14 $ * * .. Scalar Arguments .. INTEGER WHICH, M, N, STRIP, RANK, LDA REAL RTHRESH, GAP * .. * .. Array Arguments .. INTEGER ISEED( 4 ) REAL A( LDA, * ), S( * ), WORK( * ) * .. * * Purpose: * ======= * * SGNTST forms a test matrix for SGEQPF, the QR factorization with * restricted column pivoting. * * Arguments: * ========= * * WHICH (input) INTEGER * Determines what kind of matrix is generated. Setting * MN = min(M,N), we have for WHICH = * 1: The last MN/2 columns are generated with MN/2-1 * singular values equal 1 and one equal to RTHRESH/GAP. * The remaining columns are random linear combinations of * those MN/2 columns, scaled by sqrt(sqrt(eps)). * Argument STRIP is not referenced. * 2: columns 2:MN are generated with singular values between * 1 and GAP*RTHRESH in arithmetic progression. Column 1 is * a random multiple of column2. Columns MN+1:N are random * linear combinations of previous columns, scaled by * sqrt(sqrt(eps)). * Argument STRIP is not referenced. * 3: Generates an m-by-n matrix with singular values between * 1 and GAP*RTHRESH in geometric sequence. * Argument STRIP is not referenced. * 4: Generates a matrix which has STRIP * columns with norms in the order of sqrt(sqrt(eps)) * up front. The rest of the columns is generated with a * geometric distribution of singular values between 1 and * GAP*RTHRESH. * 5: Generates a matrix which has STRIP * columns with an arithmetic distribution of singular * values between 1 and GAP*RTHRESH up front. The remaining * columns are random linear combinations of these columns * with permutations of the order of sqrt(epsilon). * 6: Matrix with random singular values between 1 and * RTHRESH*GAP, except for six small singular values, which * are all small around RTHRESH*GAP. * any other value or when the matrix sizes are too small for * a selected option to make sense: * generate null matrix. * * M (input) INTEGER * The number or rows of the matrix. * * N (input) INTEGER * The number of columns of the matrix A. * * RTHRESH (input) REAL * 1/RTHRESH is the acceptance threshold for the condition * number of a matrix. * * GAP (input) REAL * GAP (.gt. ONE) determines singular values around threshold. * The smallest singular value above RTHRESH will be * GAP*RTHRESH, the next singular value below RTHRESH * will be RTHRESH/GAP. * * STRIP (input) INTEGER * The width of dependent strips. * * ISEED (input/output) INTEGER array, dimension (4) * seed for the random number generator. ISEED(4) must be odd. * * RANK (output) INTEGER * The rank of the matrix generated with respect to the * threshold 1/RTHRESH. * * S (output) REAL array, dimension min(M,N) * singular values of A * * A (output) REAL array, dimension (LDA,N) * The m-by-n matrix being generated * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= M. * * WORK (workspace) REAL array, * dimension M*N+3*max(M,min(M,N))+max(M,N) * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * * input arguments for SLATMS: * BREAK: all sing. values 1 except for last one * ARITH: arithmetic sequence * GEOM: geometric sequence * INTEGER BREAK, ARITH, GEOM PARAMETER ( BREAK = 2, GEOM = 3, ARITH = 4 ) * .. * .. Local Scalars .. INTEGER MN, WIDTH1, WIDTH2, INFO, I, J REAL DUMMY, RTEPS, EPS, TEMP * .. * .. External Subroutines .. EXTERNAL SGEMM, SCOPY, SSCAL, SLARNV, $ SGEBD2, SBDSQR * .. * .. External Functions .. EXTERNAL SLARAN, SFRANK, SNRM2, SLAMCH INTEGER SFRANK REAL SLARAN, SLAMCH, SNRM2 * .. * .. Intrinsic Functions .. INTRINSIC MIN, MAX, MOD, SQRT, REAL * .. * .. Executable Statements .. * MN = MIN( M, N ) EPS = SLAMCH( 'Epsilon' ) RTEPS = SQRT( SQRT( EPS ) ) * IF( WHICH.EQ.1 ) THEN * * columns MN/2+1:MN of A are linearly dependent with condition * number GAP/RTHRESH. * IF( MN.LE.1 ) GOTO 1111 IF( MOD( MN, 2 ).EQ.0 ) THEN WIDTH1 = MN/2 WIDTH2 = MN/2 ELSE WIDTH1 = ( MN-1 )/2 WIDTH2 = ( MN+1 )/2 END IF * * generate A(:,1+WIDTH1:MN) such that all singular values * are 1 except for last one which is RTHRESH/GAP * CALL SLATMS( M, WIDTH2, 'Uniform Distribution', ISEED, $ 'Nonsymmetric', S, -BREAK, GAP/RTHRESH, ONE, M, $ WIDTH2, 'No Packing', A( 1, WIDTH1+1 ), LDA, $ WORK, INFO ) * * multiply A(:,1+WIDTH1:MN) with a random * WIDTH2-by-WIDTH1 matrix to generate A(1,1:WIDTH1). * IF( WIDTH1.GT.0 ) THEN CALL SLARNV(1,ISEED,WIDTH1*WIDTH2,WORK(1)) CALL SGEMM( 'no transpose', 'no transpose', M, WIDTH1, $ WIDTH2, RTEPS, A( 1, WIDTH1+1 ), LDA, WORK, $ WIDTH2, ZERO, A( 1, 1 ), LDA ) END IF * * multiply A(:,1+WIDTH1:MN) with a random * WIDTH2-by-(N-MN) matrix to generate A(:,MN+1:N). * IF( MN.LT.N ) THEN CALL SLARNV(1,ISEED,WIDTH2*(N-MN),WORK(1)) CALL SGEMM( 'no transpose', 'no transpose', M, N-MN, $ WIDTH2, RTEPS, A( 1, WIDTH1+1 ), LDA, WORK, $ WIDTH2, ZERO, A( 1, MN+1 ), LDA ) END IF * * compute SVD of A * CALL SLACPY( 'full', M, N, A, LDA, WORK( MN+1 ), M ) CALL SGEBD2( M, N, WORK( MN+1 ), M, S, WORK( 1 ), $ WORK( MN+M*N+1 ),WORK( 2*MN+M*N+1 ), $ WORK( 3*MN+M*N+1 ),INFO ) CALL SBDSQR( 'upper', MN, 0, 0, 0, S, WORK(1), $ DUMMY, MN, DUMMY, 1, DUMMY, MN, WORK( MN+1 ), INFO ) * * initialize RANK * RANK = SFRANK( S, MN, RTHRESH ) RETURN ELSEIF( WHICH.EQ.2 ) THEN * * columns 2:MN are linearly independent. column 1 is dependent. * The singular values of A are similar to an arithmetic sequence * from 1 to GAP*RTHRESH. * * generate A(:,2:MN) such that singular values decline in * arithmetic progression from 1 to GAP*RTHRESH. * IF( MN.LT.2 ) GOTO 1111 CALL SLATMS( M, MN-1, 'Uniform Distribution', ISEED, $ 'Nonsymmetric', S, -ARITH, ONE/(GAP*RTHRESH), ONE, $ M,MN-1, 'No Packing', A( 1, 2 ), LDA, WORK, INFO ) * * first column is random multiple of second column * CALL SCOPY( M, A( 1, 2 ), 1, A( 1, 1 ), 1 ) CALL SSCAL( M, SLARAN( ISEED ), A( 1, 1 ), 1 ) * * multiply A(:,2:MN) with a random * (MN-1)-by-(N-MN) matrix to generate A(:,MN+1:N). * IF( MN.LT.N ) THEN CALL SLARNV( 1, ISEED, (MN-1)*(N-MN), WORK( 1 ) ) CALL SGEMM( 'no transpose' , 'no transpose', M, N-MN, $ MN-1, RTEPS, A( 1, 2 ), LDA, WORK, MN-1, ZERO, $ A( 1, MN+1 ), LDA ) END IF * * compute SVD of A * CALL SLACPY( 'full matrix', M, N, A, LDA, WORK( MN+1 ), M ) CALL SGEBD2( M, N, WORK( MN+1 ), M, S, WORK( 1 ), $ WORK( MN+M*N+1 ),WORK( 2*MN+M*N+1 ), $ WORK( 3*MN+M*N+1 ),INFO ) CALL SBDSQR( 'upper',MN, 0, 0, 0, S, WORK( 1 ), $ DUMMY, MN, DUMMY, 1, DUMMY, MN, WORK( MN+1 ), INFO ) * * initialize RANK * RANK = SFRANK( S, MN, RTHRESH ) RETURN ELSEIF( WHICH.EQ.3 ) THEN * * generate a matrix with full rank and fix the first (MN-1) * columns. The singular values are generated with a geometric * distribution. * CALL SLATMS( M, N, 'Uniform', ISEED, 'Nonsymmetric', S, $ GEOM, ONE/(GAP*RTHRESH), ONE, M, N, 'No Packing', $ A, LDA, WORK, INFO ) RANK = MN RETURN ELSEIF( WHICH.EQ.4 ) THEN * * generate a matrix which has min(STRIP,N-1) small columns up front, * the rest of the columns is independent and generated with * a geometric distribution of singular values. * WIDTH1 = MAX( 1, MIN( STRIP, N-1 ) ) DO 80 J = 1, WIDTH1 CALL SLARNV( 1, ISEED, M, A( 1, J ) ) **** CALL SSCAL(M,RTEPS,A(1,J),1) 80 CONTINUE IF( N.EQ.1 ) THEN S( 1 ) = SNRM2( M, A( 1, 1 ),1 ) RANK = 0 RETURN ELSEIF( M.EQ.1 ) THEN IF( N.GT.1 ) THEN DO 85 I = 2, N A( 1, I ) = ONE 85 CONTINUE S( 1 ) = SNRM2( N, A( 1, 1 ), LDA ) RANK = 1 ELSE S( 1 ) = ABS( A( 1, 1 ) ) RANK = 0 END IF RETURN END IF CALL SLATMS( M, N-WIDTH1, 'Uniform', ISEED, 'Nonsymmetric', $ S, GEOM, ONE/( GAP*RTHRESH ), ONE, M, N-WIDTH1, $ 'No Packing', A( 1, WIDTH1+1 ), LDA, WORK, INFO ) * * compute SVD * CALL SLACPY( 'full matrix', M, N, A, LDA, WORK( MN+1 ), M ) CALL SGEBD2( M, N, WORK( MN+1 ), M, S, WORK( 1 ), $ WORK( MN+M*N+1 ),WORK( 2*MN+M*N+1 ), $ WORK( 3*MN+M*N+1 ), INFO ) CALL SBDSQR( 'upper', MN, 0, 0, 0, S, WORK( 1 ), $ DUMMY, MN, DUMMY, 1, DUMMY, MN, WORK( MN+1 ), INFO ) RANK = SFRANK( S, MN, RTHRESH ) RETURN ELSEIF( WHICH.EQ.5 ) THEN * * generate a matrix which has STRIP independent columns up front, * using an arithmetic sequence of singular values. * The rest of the columns is generated as linear combinations of * the previous ones with a perturbation of order epsilon. * WIDTH1 = MIN( STRIP, MN ) CALL SLATMS( M, WIDTH1, 'Uniform', ISEED, 'Nonsymmetric', $ S, ARITH, ONE/( GAP*RTHRESH ), ONE, M, WIDTH1, $ 'No Packing', A, LDA, WORK, INFO ) IF( N.GT.WIDTH1 ) THEN CALL SLARNV( 1, ISEED, WIDTH1*( N-WIDTH1 ), WORK( 1 ) ) DO 110 J = WIDTH1+1, N CALL SLARNV( 1, ISEED, M, A( 1, J ) ) 110 CONTINUE CALL SGEMM( 'no transpose', 'no transpose', M, N-WIDTH1, $ WIDTH1, RTEPS, A( 1, 1 ), LDA, WORK, WIDTH1, EPS, $ A( 1, WIDTH1+1 ), LDA ) END IF * * compute SVD of A * CALL SLACPY( 'full matrix', M, N, A, LDA, WORK( MN+1 ), M ) CALL SGEBD2( M, N, WORK( MN+1 ), M, S, WORK( 1 ), $ WORK( MN+M*N+1 ), WORK( 2*MN+M*N+1 ), $ WORK( 3*MN+M*N+1 ), INFO ) CALL SBDSQR( 'upper', MN, 0, 0, 0, S, WORK( 1 ), $ DUMMY, MN, DUMMY, 1, DUMMY, MN, WORK( MN+1 ), INFO ) RANK = SFRANK( S, MN, RTHRESH ) RETURN ELSEIF( WHICH.EQ.6 ) THEN * * Peter's suggestion: Matrix with random singular values, * between 1 and RTHRESH*GAP, and six very close singular * values around RTHRESH*GAP. * S( 1 ) = ONE DO 160 I = 2, MN-6 170 TEMP = SLARAN( ISEED ) IF( TEMP.GE.RTHRESH*GAP ) THEN S( I ) = TEMP ELSE GOTO 170 END IF 160 CONTINUE DO 180 I = MAX( 2, MN-5 ), MN S( I ) = RTHRESH*GAP*( ONE+3.0*SLARAN( ISEED ) ) 180 CONTINUE CALL SLATMS( M, N, 'Uniform', ISEED, 'Nonsymmetric', S, 0, $ DUMMY, ONE, M, N, 'No Packing', A, LDA, WORK, INFO ) CALL SSORT( MN, S, 1, 'decreasing' ) RANK = MN RETURN ELSEIF( WHICH.EQ.7 ) THEN * * Generate Null matrix * DO 130 J = 1, N DO 140 I = 1, M A( I, J ) = ZERO 140 CONTINUE 130 CONTINUE DO 150 I = 1, MN S( I ) = ZERO 150 CONTINUE RANK = 0 RETURN END IF 1111 CONTINUE * * Default: Generate matrix of all ones * DO 190 J = 1,N DO 200 I = 1, M A( I, J ) = ONE 200 CONTINUE 190 CONTINUE S( 1 ) = SQRT( REAL( M*N ) ) DO 210 I = 2, MN S( I ) = ZERO 210 CONTINUE RANK = 1 RETURN * * End of SGNTST * END SHAR_EOF fi # end of overwriting check if test -f 'slasmx.f' then echo shar: will not over-write existing file "'slasmx.f'" else cat << SHAR_EOF > 'slasmx.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 'slauc1.f' then echo shar: will not over-write existing file "'slauc1.f'" else cat << SHAR_EOF > 'slauc1.f' LOGICAL FUNCTION SLAUC1( 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.84 $ * $Date: 96/12/30 16:59:16 $ * * .. Scalar Arguments .. INTEGER K REAL SMIN, GAMMA, THRESH * .. * .. Array Arguments .. REAL W( * ), X( * ) * .. * * Purpose * ======= * * SLAUC1 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) REAL 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 SLAUC1 == .TRUE., X contains an approximate * smallest left singular vector of the upper triangle of * A(1:k,1:k); if SLAUC1 == .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 SLAUC1 == .TRUE., SMIN is an estimate of the * smallest singular value of the upper triangle of A(1:k,1:k); * if SLAUC1 == .FALSE., SMIN is unchanged. * * W (input) REAL array, dimension ( K-1 ) * The K-th column of matrix A excluding the diagonal element. * * GAMMA (input) REAL * 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. * * (SLAUC1) (output) LOGICAL * If the k-th column of A is found acceptable, SLAUC1 * returns .TRUE., otherwise it returns .FALSE. * * ===================================================================== * * .. Local Scalars .. REAL SMINPR, SINE, COSINE * .. * .. External Subroutines .. EXTERNAL SLAIC1, SSCAL * .. * .. Intrinsic Functions .. INTRINSIC ABS * * .. * .. Executable Statements .. * * * Try to use diagonal element as condition estimator * IF( THRESH.GT.ABS( GAMMA ) ) THEN SLAUC1 = .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 SLAIC1( 2, K-1, X, SMIN, W, GAMMA, SMINPR, $ SINE, COSINE ) IF( THRESH.GT.SMINPR ) THEN SLAUC1 = .FALSE. ELSE CALL SSCAL( K-1, SINE, X, 1 ) X( K ) = COSINE SMIN = SMINPR SLAUC1 = .TRUE. END IF RETURN * * End of SLAUC1 * END SHAR_EOF fi # end of overwriting check if test -f 'smylap.f' then echo shar: will not over-write existing file "'smylap.f'" else cat << SHAR_EOF > 'smylap.f' ********************************************************************* SUBROUTINE SGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO ) * * -- LAPACK test 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 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * SGEQPF computes a QR factorization with column pivoting of a * real 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) REAL 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) REAL array, dimension (min(M,N)) * Stores further details of * the orthogonal matrix Q (see A). * * WORK (workspace) REAL array, dimension (3*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 real scalar, and v is a real 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 AII, TEMP, TEMP2 * .. * .. External Subroutines .. EXTERNAL SGEQR2, SLARF, SLARFG, SORM2R, SSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. External Functions .. INTEGER ISAMAX REAL SNRM2 EXTERNAL ISAMAX, 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( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SGEQPF', -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 SSWAP( 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 SGEQR2( M, MA, A, LDA, TAU, WORK, INFO ) IF( MA.LT.N ) THEN CALL SORM2R( 'Left', '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 WORK( I ) = SNRM2( M-ITEMP, A( ITEMP+1, I ), 1 ) WORK( N+I ) = WORK( 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, WORK( I ), 1 ) * IF( PVT.NE.I ) THEN CALL SSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 ) ITEMP = JPVT( PVT ) JPVT( PVT ) = JPVT( I ) JPVT( I ) = ITEMP WORK( PVT ) = WORK( I ) WORK( N+PVT ) = WORK( N+I ) END IF * * Generate elementary reflector H(i) * IF( I.LT.M ) THEN CALL SLARFG( M-I+1, A( I, I ), A( I+1, I ), 1, TAU( I ) ) ELSE CALL SLARFG( 1, A( M, M ), A( M, M ), 1, TAU( M ) ) END IF * 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 ) = ONE CALL SLARF( 'LEFT', M-I+1, N-I, A( I, I ), 1, TAU( I ), $ A( I, I+1 ), LDA, WORK( 2*N+1 ) ) A( I, I ) = AII END IF * * Update partial column norms * DO 30 J = I + 1, N IF( WORK( J ).NE.ZERO ) THEN TEMP = ONE - ( ABS( A( I, J ) ) / WORK( J ) )**2 TEMP = MAX( TEMP, ZERO ) TEMP2 = ONE + 0.05*TEMP*( WORK( J ) / WORK( N+J ) )**2 IF( TEMP2.EQ.ONE ) THEN IF( M-I.GT.0 ) THEN WORK( J ) = SNRM2( M-I, A( I+1, J ), 1 ) WORK( N+J ) = WORK( J ) ELSE WORK( J ) = ZERO WORK( N+J ) = ZERO END IF ELSE WORK( J ) = WORK( J )*SQRT( TEMP ) END IF END IF 30 CONTINUE * 40 CONTINUE END IF RETURN * * End of SGEQPF * END ********************************************************************* SUBROUTINE SGEQRF( 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 .. REAL A( LDA, * ), TAU( * ), WORK( LWORK ) * .. * * Purpose * ======= * * SGEQRF computes a QR factorization of a real 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) REAL 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 orthogonal 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) REAL array, dimension (min(M,N)) * The scalar factors of the elementary reflectors (see Further * Details). * * WORK (workspace) REAL 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 real scalar, and v is a real 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 SGEQR2, SLARFB, SLARFT, 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( 'SGEQRF', -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, 'SGEQRF', ' ', 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, 'SGEQRF', ' ', 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, 'SGEQRF', ' ', 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 SGEQR2( 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 SLARFT( '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 SLARFB( 'Left', '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 SGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, $ IINFO ) * WORK( 1 ) = IWS RETURN * * End of SGEQRF * END ********************************************************************* SUBROUTINE SGEQR2( 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 .. REAL A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * SGEQR2 computes a QR factorization of a real 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) REAL 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 orthogonal 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) REAL array, dimension (min(M,N)) * The scalar factors of the elementary reflectors (see Further * Details). * * WORK (workspace) REAL 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 real scalar, and v is a real 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 .. REAL ONE PARAMETER ( ONE = 1.0E+0 ) * .. * .. Local Scalars .. INTEGER I, K REAL AII * .. * .. External Subroutines .. EXTERNAL SLARF, SLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC 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( 'SGEQR2', -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 SLARFG( 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 * AII = A( I, I ) A( I, I ) = ONE CALL SLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), $ A( I, I+1 ), LDA, WORK ) A( I, I ) = AII END IF 10 CONTINUE RETURN * * End of SGEQR2 * END ********************************************************************* SHAR_EOF fi # end of overwriting check if test -f 'sqr.f' then echo shar: will not over-write existing file "'sqr.f'" else cat << SHAR_EOF > 'sqr.f' PROGRAM Sqr * * Test and timing program for the Rank-Revealing QR factorization. * * 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.84 $ * $Date: 96/12/30 16:59:17 $ * * Constants: * ========= * REAL ZERO, ONE, HUNDRED, MILLION PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, $ HUNDRED = 1.0E+2, MILLION = 1.0E+6 ) INTEGER MMAX, NMAX, MAXTEST, NBMAX, uin, uoutrl, uoutfl PARAMETER ( MMAX=1001, NMAX=MMAX, NBMAX=64, MAXTEST=9, $ uin=15, uoutrl=16, uoutfl=17 ) * * Make sure that MAXTEST<=9; otherwise some format statememts bomb. CHARACTER*6 infile PARAMETER (infile = 'Sqr.in') * lda, nmax test matrix array is lda -by- nmax * MAXTEST maximal number of test values for any PARAMETER * is assumed to be less than 10 !!! * NBMAX maximal blocksize * uin/uout unit number for input/output file * infile name of input file integer flppre, flpice, flppst common /CNTFLP/ flppre, flpice, flppst * flppre variable used to accumulate the number of flops * performed in the preprocessing * flppst variable used to accumulate the number of flops * performed in the postprocessing * flpice variable used to accumulate the number of flops * performed in ICE, both in pre and postprocessing INTEGER PERFMSR, TIME, FLOPS, MFLOPS, NORUNS, STFLPS, $ RLFLPS, STMFLP, RLMFLP, TRANK, TRCOND, $ ICFLPS, POFLPS PARAMETER ( PERFMSR = 10, TIME = 1, STFLPS = 2, $ STMFLP = 3, RLFLPS = 4, RLMFLP = 5, NORUNS=6, $ FLOPS = 2, MFLOPS = 3, TRANK = 7, TRCOND = 8, $ ICFLPS = 9, POFLPS = 10 ) * PERFMSR number of performance measures taken * TIME total execution time in seconds * STFLPS the no. of flops required by the standard algorithm * (xGEQR2: non-block QR factorization with no pivoting) * STMFLP execution rate defined by STFLPS * RLFLPS the number of floating point operations actually * performed. * RLMFLP execution rate defined by RLFLPS. * NORUNS total number of runs executed * FLOPS the same as STMFLP for the classical algorithms * where STFLPS = RLFLPS * MFLOPS the execution rate induced by FLOPS * TRANK rank as returned by QR routine * TRCOND inverse of estimated condition number INTEGER RELMSR, ACCEPTED, ESTRK, IRCOND, DRCOND, $ ISMAX,DSMAX, ISBEFOR, DSBEFOR, $ ISAFTER, DSAFTER, ISMIN, DSMIN PARAMETER ( RELMSR = 12, $ ACCEPTED = 1, ESTRK = 2, $ IRCOND = 3, DRCOND = 4, $ ISMAX = 5, DSMAX = 6, $ ISBEFOR = 7, DSBEFOR = 8, $ ISAFTER = 9, DSAFTER = 10, $ ISMIN = 11, DSMIN = 12 ) * Let R1 = R(1:accepted,1:accepted), * R2 = R(1:r,1:r), where r = min(mn,accepted+1) * * RELMSR number of reliability data sampled * ACCEPTED number of columns that was accepted * ESTRK estimated rank (input to xGEQPX and xGEQPY) * IRCOND inverse of condition number of R1 * DRCOND the factor rcond_hat/rcond * ISMAX largest singular value of R1 * DSMAX the factor smax/smax_hat * ISBEFOR smallest singular value of R1 * DSBEFOR the factor sbefor_hat/sbefor * ISAFTER smallest singular value of R2 * DSAFTER the factor safter_hat/safter * ISMIN the smallest singular value of R * DSMIN the factor smin_hat/smin * * Indices into the 'svlues' array returned by xGEQPX and xGEQPY * * * Indices into the 'svlues' array. * INTEGER IMAX, IBEFOR, IAFTER, IMIN PARAMETER ( IMAX = 1, IBEFOR = 2, IAFTER = 3, IMIN = 4 ) * .. INTEGER LINRTS, BL1, BL2 PARAMETER ( LINRTS = 2, BL1 = 1, BL2 = 2 ) CHARACTER*6 LINNAMES(LINRTS) * LINRTS number of versions of LINPACK QR routine with column * pivoting * BL1 blas 1 version * BL2 blas 2 version * LINNAMES LINNAMES(i) is the name of routine i, i in {BL1,BL2} INTEGER TOPTMAX, GNTST, QRMTX, LATMS PARAMETER ( TOPTMAX = 3, GNTST = 1, QRMTX = 2, $ LATMS = 3 ) CHARACTER*6 ctopt( TOPTMAX ) * TOPTMAX number of test matrix generators * GNTST testing special cases * QRMTX routine xQRMTX generating strips of dependent and * independent columns * LATMS routine xLATMS -- LAPACK test matrix generator * ctopt ctopt(i) is the name or routine i, * i in {GNTST,QRMTX,LATMS} INTEGER MODEMAX, FIX1, FIX2, FULLRK, SMFRNT, SMBACK, $ NLLMTX, PETER, BREAK1, GEOM, ARITH PARAMETER ( MODEMAX = 7, FIX1 = 1, FIX2 = 2, FULLRK = 3, $ SMFRNT = 4, SMBACK = 5, PETER = 6, NLLMTX = 7, $ BREAK1 = 2, GEOM = 3, ARITH = 4 ) CHARACTER*40 cmode( TOPTMAX, -MODEMAX:MODEMAX ) * MODEMAX maximal number of different distributions that can * be generated by any of the test matrix generators. * MAKE SURE that MODEMAX >= 2*(# of options for * distributions SLATMS) * otherwise arrays for holding 'mode' are too short. * * options for xGNTST: * FIX1 matrix w/ rank MN/2-1 * FIX2 cols 2:MN full rank, rest dep. * FULLRK full rank * SMFRNT STRIP small cols up front, rest indep. * SMBACK STRIP indep. cols up front, rest dep. * PETER Peter Tang's distribution: a few small singular * values that are very close together. * NLLMTX null matrix * * options for xQRMTX and XLATMS: * BREAK1 break1 distribution * GEOM geometric distribution * ARITH arithmetic distribution * * cmode cmode(topt,i) is a description of the matrix that * is generated by routine referred to as topt with * argument 'mode' set to 'i'. * * INTRINSICS: * =========== * INTRINSIC REAL, MAX, MIN * * ******************************** * * Variables read by input file * * ******************************** CHARACTER*40 outfile INTEGER m, nm, am(MAXTEST), im, $ n, nn, an(MAXTEST), in, $ nb, nnb, anb(MAXTEST),inb, $ topt,ntopt,atopt(TOPTMAX),itopt, $ nmod1,amod1(MODEMAX), $ nmod2,amod2(MODEMAX), $ nmod3,amod3(MODEMAX), $ mode,nmode,amode(MODEMAX),imode, $ strip, iseed(4), job, k REAL irthresh, orthresh, gap, timmin, scale * outfile name of output file * m number of rows of test matrix (m.LE.MMAX) * n number of columns of test matrix (n.LE.NMAX) * n bblock size (nb. le. NBMAX) * topt different test matrix generators to be CALLed * =1: CALL SGNTST * =2: CALL SQRMTX * =3: CALL SLATMS * mod1 distributions to generate for xGNTST * mod2 distributions to generate for xQRMTX * mod3 distributions to generate for xLATMS * mode distributions to generate for matrix generator * actually chosen. * dfct different ways of choosing estimated rank of A. * For each of in {m,n,nb,topt,mod1,mod2,mod3,mode,dfct}, * n is the number of values for test for , a is * an array holding these test values, and i is the loop * variable for the loop stepping through a. * strip choice of strip width for xGNTST and xQRMTX * scale epsilon**scale is taken to multiply dependent * columns in xQRMTX. * irthresh (input) inverse of threshold for condition number of a * matrix * orthresh (output) inverse of threshold for condition number of a * matrix * gap gap around threshold for generating dependent or * full rank matrices * timmin minimum time for a benchmark run * iseed array to initialize the random number generator * iseed(4) must be odd * * ******************** * * Other variables: * * ******************** * * SCALARS * ======= * INTEGER mn, lda, i, j, nobefore, rank, $ runs, ls, info, oiseed(4) REAL eps, bstrcond, t1, t2, trt, $ smax, smin, smaxpr, sminpr, mnrm, mnrmpr, $ realsmin, temp CHARACTER*1 c1 CHARACTER*80 fmt * * mn shorthand for min(m,n) * lda leading dimension of A * nobefore the rank of A with respect to the threshold rcond. * rank on output the rank determined by xGEQPB, xGEQPX and xGEQPY. * runs number of runs needed to accumulate timmin seconds * iseed seed for xLATMS * bstrcond equal to s(nobefore)/s(1) * ls length of work array for xGEQPB, xGEQPX and xGEQPY * info return PARAMETER of LAPACK routines * eps machine precision * trt total run time * smax estimate for largest singular value * smin estimate for smallest singular value * * FOR PERFORMANCE MEASUREMENT * =========================== REAL ttime, tircond, tdrcond, tismax, $ tdsmax, tisbefor, tdsbefor, tisafter, $ tdsafter, tismin, tdsmin INTEGER taccptd REAL lint(LINRTS,PERFMSR), $ cwytnop(MAXTEST,PERFMSR), $ cwytqpb(MAXTEST,PERFMSR), $ cwytqpx(MAXTEST,PERFMSR), $ cwytqpy(MAXTEST,PERFMSR) * lint performance results for linpack routines * linr reliability data for linpack routines * need only one value since routines DO identical operations * cwytnop performance results for xGEQRF * cwytqpb performance results for xGEQPB (preprocessing) * cwyrqpb reliability data for xGEQPB (preprocessing) * cwytqpx performance results for xGEQPX (pre + post(Chandra&Ipsen) * cwyrqpx reliability data for xGEQPX (pre + post(Chandra&Ipsen) * cwytqpy performance results for xGEQPY (pre + post(Pan&Tang) * cwyrqpy reliability data for xGEQPY (pre + post(Pan&Tang) * all others * temporary variables for time, error and so on. * ARRAYS FOR MATRICES * =================== REAL a(MMAX,NMAX), copya(MMAX,NMAX), s(MMAX), $ copys(MMAX), qraux(NMAX), svlues(4) INTEGER jpvt(NMAX) * * a, copya matrix to be factored * s, copys singular values of A * jpvt pivot vector * WORK SPACE * ========== REAL work(MMAX*NMAX+4*MMAX+NMAX),wk1(mmax,mmax) * we check later on that the length of work is sufficient * make sure to keep this check consistent with changes in * this declaration * * COMMON BLOCK FOR LAPACK ENVIRONMENT PARAMETERS * ============================================== INTEGER nblk, nmnblk, nxover common /cenvir/ nblk, nmnblk, nxover * nblk is the ideal blocksize * mnblk is the minimal blocksize * nxover is the crossover point below which an unblocked alg is used * * EXTERNAL ENTRIES * ================ * EXTERNAL SECOND, SGNTST, SQRMTX, $ SLATMS, SNRM2, iscle, iarle, find, $ SLAMCH, sfrank, flXGEQPF, flXGEQRF, $ flXGEQR2, SLASMX REAL SECOND, SNRM2, SLAMCH, SLASMX INTEGER flXGEQPF, flXGEQRF, flXGEQR2, sfrank LOGICAL iscle, iarle, find * iscle checks INTEGER scalar against bound * iarle checks INTEGER array against bound * flops... number of flops of LAPACK routines * * ***************************** * * start of executable stmts * * ***************************** * Initialize arrays describing testing options * ============================================ * DATA lint(BL1,TRANK) /0/, lint(BL1,TRCOND) /0/, $ (cwytnop(i,TRANK),i=1,MAXTEST) /MAXTEST*0/, $ (cwytnop(i,TRCOND),i=1,MAXTEST) /MAXTEST*0/ * set to zero in case we don't DO error check data LINNAMES /'SQRDC ','SGEQPF'/ data ctopt /'SGNTST','SQRMTX','SLATMS'/ cmode(GNTST,NLLMTX) = 'null matrix' cmode(GNTST,FIX1) = 'matrix w/ rank MN/2-1' cmode(GNTST,FIX2) = 'cols 2:MN full rank, rest dep.' cmode(GNTST,FULLRK) = 'full rank' cmode(GNTST,SMFRNT) = 'STRIP small cols up front, rest indep.' cmode(GNTST,SMBACK) = 'STRIP indep. cols up front, rest dep.' cmode(GNTST,PETER) = 'Peter''s: 5 small close sing. values' cmode(QRMTX,BREAK1) = 'break1 distribution' cmode(QRMTX,GEOM) = 'geometric distribution' cmode(QRMTX,ARITH) = 'arithmetic distribution' cmode(QRMTX,-BREAK1) = 'break1 distribution reversed' cmode(QRMTX,-GEOM) = 'geometric distribution reversed' cmode(QRMTX,-ARITH) = 'arithmetic distribution reversed' j = MAX(ARITH,BREAK1,GEOM) DO 230 i = -j,j cmode(LATMS,i) = cmode(QRMTX,i) 230 CONTINUE * * Envir common block initialization * ================================= * nmnblk = 1 nxover = 1 lda = mmax eps = SLAMCH('epsilon') * ***************************************************** * * read data from input file and copy to output file * * ***************************************************** * OPEN(uin,file=infile) REWIND(uin) * name of output file READ(uin,*) outfile OPEN(uoutrl,file='rank.'//outfile) OPEN(uoutfl,file='time.'//outfile) REWIND(uoutrl) REWIND(uoutfl) WRITE(uoutrl,1040) outfile WRITE(uoutfl,1040) outfile * values for m READ(uin,*) nm IF( .not. iscle('nm',nm,MAXTEST) ) STOP READ(uin,*)(am(i),i=1,nm) IF( .not. iarle('am',am,nm,lda) ) STOP WRITE(c1,'(i1)') nm fmt = '(1x,i1,'' nm'',/,1x,'//c1//'(i4,2x),'' m'')' WRITE(uoutrl,fmt) nm,(am(i),i=1,nm) WRITE(uoutfl,fmt) nm,(am(i),i=1,nm) * values for n READ(uin,*) nn IF( .not. iscle('nn',nn,MAXTEST) ) STOP READ(uin,*)(an(i),i=1,nn) IF( .not. iarle('an',an,nn,nmax) ) STOP WRITE(c1,'(i1)') nn fmt = '(1x,i1,'' nn'',/,1x,'//c1//'(i4,2x),'' n'')' WRITE(uoutrl,fmt) nn, (an(i),i=1,nn) WRITE(uoutfl,fmt) nn, (an(i),i=1,nn) * block sizes READ(uin,*) nnb IF( .not. iscle('nnb',nnb,MAXTEST) ) STOP READ(uin,*)(anb(i),i=1,nnb) IF( .not. iarle('anb',anb,nnb,NBMAX) ) STOP CALL isort(nnb,anb,'i') IF( anb(1).NE.1 ) THEN WRITE(*,*) '*** ERROR: specify nb = 1 as well ***' STOP END IF WRITE(c1,'(i1)') nnb fmt = '(1x,i1,'' nnb'',/,1x,'//c1//'(i2,2x),'' nb'')' WRITE(uoutrl,fmt) nnb, (anb(i),i=1,nnb) WRITE(uoutfl,fmt) nnb, (anb(i),i=1,nnb) * test matrix generation routines READ(uin,*) ntopt IF( .not. iscle('ntopt',ntopt,TOPTMAX) ) STOP READ(uin,*) (atopt(i),i=1,ntopt) IF( .not. iarle('atopt',atopt,ntopt,TOPTMAX) ) STOP WRITE(c1,'(i1)') ntopt fmt = '(1x,i1,'' ntopt'',/,1x,'//c1//'(i3,2x),'' topt'')' WRITE(uoutrl,fmt) ntopt, (atopt(i),i=1,ntopt) WRITE(uoutfl,fmt) ntopt, (atopt(i),i=1,ntopt) * test cases for xGNTST READ(uin,*) nmod1 IF( .not. iscle('nmod1',nmod1,MODEMAX) ) STOP READ(uin,*) (amod1(i),i=1,nmod1) IF( .not. iarle('amod1',amod1,nmod1,MODEMAX) ) STOP IF( find(GNTST,atopt,ntopt) ) THEN WRITE(c1,'(i1)') nmod1 fmt = '(1x,i1,'' nmod1'',/,1x,'//c1//'(i3,2x),'' mod1'')' WRITE(uoutrl,fmt) nmod1, (amod1(i),i=1,nmod1) WRITE(uoutfl,fmt) nmod1, (amod1(i),i=1,nmod1) END IF j = MAX(BREAK1,GEOM,ARITH) * singular value distributions for xQRMTX READ(uin,*) nmod2 IF( .not. iscle('nmod2',nmod2,MODEMAX) ) STOP READ(uin,*) (amod2(i),i=1,nmod2) IF( .not. iarle('amod2',amod2,nmod2,j) ) STOP IF( find(QRMTX,atopt,ntopt) ) THEN WRITE(c1,'(i1)') nmod2 fmt = '(1x,i1,'' nmod2'',/,1x,'//c1//'(i3,2x),'' mod2'')' WRITE(uoutrl,fmt) nmod2, (amod2(i),i=1,nmod2) WRITE(uoutfl,fmt) nmod2, (amod2(i),i=1,nmod2) END IF * singular value distributions for xLATMS READ(uin,*) nmod3 IF( .not. iscle('nmod3',nmod3,MODEMAX) ) STOP READ(uin,*) (amod3(i),i=1,nmod3) IF( .not. iarle('amod3',amod3,nmod3,j) ) STOP IF( find(LATMS,atopt,ntopt) ) THEN WRITE(c1,'(i1)') nmod3 fmt = '(1x,i1,'' nmod3'',/,1x,'//c1//'(i3,2x),'' mod3'')' WRITE(uoutrl,fmt) nmod3, (amod3(i),i=1,nmod3) WRITE(uoutfl,fmt) nmod3, (amod3(i),i=1,nmod3) END IF * strip width for xGNTST and xQRMTX READ(uin,*) strip IF( find(QRMTX,atopt,ntopt).OR.find(GNTST,atopt,ntopt) ) THEN WRITE(uoutrl,1050) strip WRITE(uoutfl,1050) strip END IF * scale factor for dependent columns in xQRMTX READ(uin,*) scale scale = eps**scale IF( find(QRMTX,atopt,ntopt) ) THEN WRITE(uoutrl,1060) scale WRITE(uoutfl,1060) scale END IF * inverse of acceptance threshold for condition number READ(uin,*) irthresh WRITE(uoutrl,1070) irthresh WRITE(uoutfl,1070) irthresh * gap around acceptance threshold READ(uin,*) gap WRITE(uoutrl,1080) gap WRITE(uoutfl,1080) gap * minimum time for a benchmark run READ(uin,*) timmin WRITE(uoutrl,1020) timmin WRITE(uoutfl,1020) timmin * seed for random number generator READ(uin,*) (iseed(i),i=1,4) IF( mod(iseed(4),2).EQ.0 ) THEN WRITE(*,1090) iseed(4) STOP END IF WRITE(uoutrl,1030) iseed WRITE(uoutfl,1030) iseed trt = SECOND() * * save values that are overwritten by xGEQPX and xGEQPY * * *************** * *************** * ** Test loop ** * *************** * *************** DO 9001 im = 1,nm m = am(im) DO 9002 in = 1,nn n = an(in) mn = min(m,n) DO 9003 itopt = 1,ntopt topt = atopt(itopt) IF( topt.EQ.GNTST ) THEN nmode = nmod1 CALL icopy(nmod1,amod1,amode) ELSEIF( topt.EQ.QRMTX ) THEN nmode = nmod2 CALL icopy(nmod2,amod2,amode) ELSEIF( topt.EQ.LATMS ) THEN nmode = nmod3 CALL icopy(nmod3,amod3,amode) END IF DO 9004 imode = 1,nmode mode = amode(imode) oiseed(1) = iseed(1) oiseed(2) = iseed(2) oiseed(3) = iseed(3) oiseed(4) = iseed(4) * * generate test matrix of size m by n using * test matrix generator indicated by 'topt' * and singular value distribution by 'mode'. * ***************************************** * IF( topt.EQ.GNTST ) THEN CALL SGNTST(mode,m,n,irthresh,gap,strip,iseed, $ rank,s,a,lda,work) ELSEIF( topt.EQ.QRMTX ) THEN CALL SQRMTX('all',scale,m,n,irthresh*gap,strip, $ mode,iseed,rank,s,a,lda,work) rank = sfrank(s,mn,irthresh) ELSEIF( topt.EQ.LATMS ) THEN CALL SLATMS(M,N,'Uniform',iseed,'nonsymmetric', $ s,mode,gap/irthresh,ONE,m,n, $ 'no packing',a,lda,work,info) IF( mode.LT.0 ) THEN CALL Ssort(mn,s,1,'decreasing') END IF rank = sfrank(s,mn,irthresh) END IF * * Save A, its singular values, and the acceptance * threshold as well as the best condition number for * R that can be achieved. Also save rank with * respect to 'irthresh'. * ================================================== * CALL SLACPY('all',m,n,a,lda,copya,lda) CALL SCOPY(mn,s,1,copys,1) IF( rank.GT.0 ) THEN nobefore = rank bstrcond = s(nobefore)/s(1) ELSE nobefore = 1 bstrcond = ZERO END IF realsmin = s(mn) * * Write info to output file and console * ===================================== WRITE(uoutrl,1200) m,n,ctopt(topt),cmode(topt,mode), $ strip,irthresh,gap, $ rank, nobefore,bstrcond, $ s(1),s(nobefore), $ s(min(mn,nobefore+1)), s(mn), $ oiseed WRITE(uoutfl,1200) m,n,ctopt(topt),cmode(topt,mode), $ strip,irthresh,gap, $ rank, nobefore,bstrcond, $ s(1),s(nobefore), $ s(min(mn,nobefore+1)), s(mn), $ oiseed * ********************** * * LINPACK QR BLAS 1 * * ********************** * DO enough runs for the aggregate runtime to be more * than ''timmin'' * runs = 0 t1 = SECOND() 10 CONTINUE CALL izero(n,jpvt) CALL SLACPY('all',m,n,copya,lda,a,lda) CALL SQRDC(a,lda,m,n,qraux,jpvt,work,1) t2 = SECOND() ttime = t2 - t1 runs = runs + 1 IF( ttime.LT.timmin ) GOTO 10 * * subtract the time for the SLACPY calls * CALL SLACPY('all',m,n,a,lda,wk1,m) t1 = SECOND() DO 20 j = 1,runs CALL SLACPY('all',m,n,copya,lda,a,lda) 20 CONTINUE ttime = (ttime - (SECOND() - t1))/runs IF( ttime.LE.ZERO ) ttime = ZERO CALL SLACPY('all',m,n,wk1,m,a,lda) * * save test results * lint(BL1,TIME) = ttime lint(BL1,FLOPS) = REAL(flXGEQR2(m,n)) IF( ttime .EQ. ZERO ) THEN lint(BL1,MFLOPS) = ZERO ELSE lint(BL1,MFLOPS) = lint(BL1,FLOPS)/ttime/MILLION END IF lint(BL1,NORUNS) = REAL(runs) * * * ************************************ * * LAPACK QR WITH PIVOTING (BLAS-2) * * ************************************ * DO enough runs for the aggregate runtime to be more * than ''timmin'' * runs = 0 t1 = SECOND() 100 CONTINUE CALL izero(n,jpvt) CALL SLACPY('all',m,n,copya,lda,a,lda) CALL SGEQPF(m,n,a,lda,jpvt,qraux,work,info) t2 = SECOND() ttime = t2 - t1 runs = runs + 1 IF( ttime.LT.timmin ) GOTO 100 * * subtract the time for the SLACPY calls * CALL SLACPY('all',m,n,a,lda,wk1,m) t1 = SECOND() DO 110 j = 1,runs CALL SLACPY('all',m,n,copya,lda,a,lda) 110 CONTINUE ttime = (ttime - (SECOND() - t1))/runs IF( ttime.LE.ZERO ) ttime = ZERO CALL SLACPY('all',m,n,wk1,m,a,lda) * * determine what columns would be accepted * smax = abs(a(1,1)) smin = abs(a(1,1)) mnrm = smin IF( abs(a(1,1)).LT.irthresh ) THEN taccptd = 0 tircond = abs(a(1,1)) tdrcond = ONE tismax = tircond tdsmax = ONE tisbefor = tircond tdsbefor = ONE tisafter = abs(a(min(mn,2),min(mn,2))) tdsafter = ONE tismin = abs(a(mn,mn)) IF( realsmin.GT.ZERO ) THEN tdsmin = tismin/realsmin ELSE tdsmin = ONE END IF ELSE DO 120 i = 1,mn mnrmpr = MAX(mnrm,SNRM2(i,a(1,i),1)) smaxpr = SLASMX(i)*mnrmpr sminpr = min(smin,abs(a(i,i))) IF( smaxpr*irthresh.GT.sminpr ) THEN taccptd = i - 1 GOTO 130 ELSE smax = smaxpr smin = sminpr mnrm = mnrmpr END IF 120 CONTINUE taccptd = mn 130 CONTINUE END IF * * save timing results * lint(BL2,TIME) = ttime lint(BL2,FLOPS) = lint(BL1,FLOPS) IF( ttime.EQ.ZERO ) THEN lint(BL2,MFLOPS) = ZERO ELSE lint(BL2,MFLOPS) = lint(BL1,FLOPS)/ttime/MILLION END IF lint(BL2,NORUNS) = REAL(runs) lint(BL2,TRANK) = REAL(taccptd) IF( smax.EQ.ZERO ) THEN lint(BL2,TRCOND) = ZERO ELSE lint(BL2,TRCOND) = smin/smax END IF lint(BL1,TRANK) = lint(BL2,TRANK) lint(BL1,TRCOND) = lint(BL2,TRCOND) * * Try for all different block sizes * *********************************** DO 9005 inb = 1,nnb nb = anb(inb) nblk = nb * * ****************************** * * LAPACK QR WITHOUT PIVOTING * * ****************************** * DO enough runs for the aggregate runtime to be more * than ''timmin'' * runs = 0 t1 = SECOND() 200 CONTINUE CALL SLACPY('all',m,n,copya,lda,a,lda) CALL SGEQRF(m,n,a,lda,qraux,work,n*nb,info) t2 = SECOND() ttime = t2 - t1 runs = runs + 1 IF( ttime.LT.timmin ) GOTO 200 * * subtract the time for the SLACPY calls * CALL SLACPY('all',m,n,a,lda,wk1,m) t1 = SECOND() DO 220 j = 1,runs CALL SLACPY('all',m,n,copya,lda,a,lda) 220 CONTINUE ttime = (ttime - (SECOND() - t1))/runs IF( ttime.LE.ZERO ) ttime = ZERO CALL SLACPY('all',m,n,wk1,m,a,lda) * * save test results * cwytnop(inb,TIME) = ttime cwytnop(inb,STFLPS) = REAL(flXGEQR2(m,n)) cwytnop(inb,RLFLPS) = REAL(flXGEQRF(m,n,nb)) IF( ttime.EQ.ZERO ) THEN cwytnop(inb,STMFLP) = ZERO cwytnop(inb,RLMFLP) = ZERO ELSE cwytnop(inb,STMFLP) = $ cwytnop(inb,STFLPS)/ttime/MILLION cwytnop(inb,RLMFLP) = $ cwytnop(inb,RLFLPS)/ttime/MILLION END IF cwytnop(inb,NORUNS) = REAL(runs) * * Linpack pivoting strategy is achieved through * setting nb = 1 * * ******************************** * * BLOCK QR WITH LOCAL PIVOTING * * ******************************** job = 1 k = 0 * Length of work array for SGEQPB IF( job.EQ.1 ) THEN IF( nb.EQ.1 ) THEN ls = 2*min(m,n)+3*n ELSE ls = 2*min(m,n)+n*nb END IF ELSE IF( nb.EQ.1 ) THEN ls = 2*min(m,n)+2*n+max(k,n) ELSE ls = 2*min(m,n)+nb*nb+nb*max(k,n) END IF END IF ls = MAX(1,ls) IF( ls.GT.MMAX*NMAX+4*MMAX+NMAX ) THEN WRITE(*,*) '**error in xqr.F(SGEQPB):', $ 'workspace too short' END IF * DO enough runs for the aggregate runtime to be more * than ''timmin'' runs = 0 t1 = SECOND() 300 CONTINUE flppre = 0 flpice = 0 flppst = 0 CALL SLACPY('all',m,n,copya,lda,a,lda) CALL SGEQPB(job,m,n,k,a,lda,wk1,mmax,jpvt, $ irthresh,orthresh,rank,svlues,work,ls, $ info) t2 = SECOND() ttime = t2 - t1 runs = runs + 1 IF( ttime.LT.timmin ) GOTO 300 * * subtract the time for the SLACPY calls * CALL SLACPY('all',m,n,a,lda,wk1,m) t1 = SECOND() DO 320 j = 1,runs CALL SLACPY('all',m,n,copya,lda,a,lda) 320 CONTINUE ttime = (ttime - (SECOND() - t1))/runs IF( ttime.LE.ZERO ) ttime = ZERO CALL SLACPY('all',m,n,wk1,m,a,lda) * * save timing results * cwytqpb(inb,TIME) = ttime cwytqpb(inb,STFLPS) = lint(BL1,FLOPS) IF( ttime.EQ.ZERO ) THEN cwytqpb(inb,STMFLP) = ZERO ELSE cwytqpb(inb,STMFLP) = $ cwytqpb(inb,STFLPS)/ttime/MILLION END IF cwytqpb(inb,ICFLPS) = REAL(flpice) cwytqpb(inb,POFLPS) = REAL(flppst) cwytqpb(inb,RLFLPS) = REAL(flppre)+ $ REAL(flpice)+REAL(flppst) IF( ttime.EQ.ZERO ) THEN cwytqpb(inb,RLMFLP) = ZERO ELSE cwytqpb(inb,RLMFLP) = $ cwytqpb(inb,RLFLPS)/ttime/MILLION END IF cwytqpb(inb,NORUNS) = REAL(runs) cwytqpb(inb,TRANK) = REAL(rank) cwytqpb(inb,TRCOND) = orthresh * * *********************************** * * xGEQPX: PRE and POSTPROCESSING * * * Modified Chandrasekaran & Ipsen * * *********************************** job = 1 k = 0 * Length of work array for SGEQPB IF( job.EQ.1 ) THEN IF( nb.EQ.1 ) THEN ls = 2*min(m,n)+3*n ELSE ls = 2*min(m,n)+n*nb END IF ELSE IF( nb.EQ.1 ) THEN ls = 2*min(m,n)+2*n+max(k,n) ELSE ls = 2*min(m,n)+nb*nb+nb*max(k,n) END IF END IF ls = MAX(1,ls) IF( ls.GT.MMAX*NMAX+4*MMAX+NMAX ) THEN WRITE(*,*) '**error in xqr.F (SGEQPX):', $ 'workspace too short' END IF * DO enough runs for the aggregate runtime to be more * than ''timmin'' runs = 0 t1 = SECOND() 400 CONTINUE flppre = 0 flpice = 0 flppst = 0 CALL SLACPY('all',m,n,copya,lda,a,lda) CALL SGEQPX(job,m,n,k,a,lda,wk1,mmax,jpvt, $ irthresh,orthresh,rank,svlues,work,ls, $ info) t2 = SECOND() ttime = t2 - t1 runs = runs + 1 * * Check if xGEQPX was ok. * IF( info.NE.0 ) $ WRITE(*,*) 'SGEQPX. Info:',info IF( ttime.LT.timmin ) GOTO 400 * * subtract the time for the SLACPY calls * CALL SLACPY('all',m,n,a,lda,wk1,m) t1 = SECOND() DO 420 j = 1,runs CALL SLACPY('all',m,n,copya,lda,a,lda) 420 CONTINUE ttime = (ttime - (SECOND() - t1))/runs IF( ttime.LE.ZERO ) ttime = ZERO CALL SLACPY('all',m,n,wk1,m,a,lda) * * save timing results * cwytqpx(inb,TIME) = ttime cwytqpx(inb,STFLPS) = lint(BL1,FLOPS) IF( ttime.EQ.ZERO ) THEN cwytqpx(inb,STMFLP) = ZERO ELSE cwytqpx(inb,STMFLP) = $ cwytqpx(inb,STFLPS)/ttime/MILLION END IF cwytqpx(inb,ICFLPS) = REAL(flpice) cwytqpx(inb,POFLPS) = REAL(flppst) cwytqpx(inb,RLFLPS) = REAL(flppre)+ $ REAL(flpice)+REAL(flppst) IF( ttime.EQ.ZERO ) THEN cwytqpx(inb,RLMFLP) = ZERO ELSE cwytqpx(inb,RLMFLP) = $ cwytqpx(inb,RLFLPS)/ttime/MILLION END IF cwytqpx(inb,NORUNS) = REAL(runs) cwytqpx(inb,TRANK) = REAL(rank) cwytqpx(inb,TRCOND) = orthresh * * ********************************** * * xGEQPY: PRE and POSTPROCESSING * * * Modified Pan & Tang * * ********************************** job = 1 k = 0 * Length of work array for SGEQPB IF( job.EQ.1 ) THEN IF( nb.EQ.1 ) THEN ls = 2*min(m,n)+3*n ELSE ls = 2*min(m,n)+n*nb END IF ELSE IF( nb.EQ.1 ) THEN ls = 2*min(m,n)+2*n+max(k,n) ELSE ls = 2*min(m,n)+nb*nb+nb*max(k,n) END IF END IF ls = MAX(1,ls) IF( ls.GT.MMAX*NMAX+4*MMAX+NMAX ) THEN WRITE(*,*) '**error in xqr.F (SGEQPY):', $ 'workspace too short' END IF * DO enough runs for the aggregate runtime to be more * than ''timmin'' runs = 0 t1 = SECOND() 500 CONTINUE flppre = 0 flpice = 0 flppst = 0 CALL SLACPY('all',m,n,copya,lda,a,lda) CALL SGEQPY(job,m,n,k,a,lda,wk1,mmax,jpvt, $ irthresh,orthresh,rank,svlues,work,ls, $ info) t2 = SECOND() ttime = t2 - t1 runs = runs + 1 * * Check if xGEQPY was ok. * IF( info.NE.0 ) $ WRITE(*,*) 'SGEQPY. Info:',info IF( ttime.LT.timmin ) GOTO 500 * * subtract the time for the SLACPY calls * CALL SLACPY('all',m,n,a,lda,wk1,m) t1 = SECOND() DO 520 j = 1,runs CALL SLACPY('all',m,n,copya,lda,a,lda) 520 CONTINUE ttime = (ttime - (SECOND() - t1))/runs IF( ttime.LE.ZERO ) ttime = ZERO CALL SLACPY('all',m,n,wk1,m,a,lda) * * save timing results * cwytqpy(inb,TIME) = ttime cwytqpy(inb,STFLPS) = lint(BL1,FLOPS) IF( ttime.EQ.ZERO ) THEN cwytqpy(inb,STMFLP) = ZERO ELSE cwytqpy(inb,STMFLP) = $ cwytqpy(inb,STFLPS)/ttime/MILLION END IF cwytqpy(inb,ICFLPS) = REAL(flpice) cwytqpy(inb,POFLPS) = REAL(flppst) cwytqpy(inb,RLFLPS) = REAL(flppre)+ $ REAL(flpice)+REAL(flppst) IF( ttime.EQ.ZERO ) THEN cwytqpy(inb,RLMFLP) = ZERO ELSE cwytqpy(inb,RLMFLP) = $ cwytqpy(inb,RLFLPS)/ttime/MILLION END IF cwytqpy(inb,NORUNS) = REAL(runs) cwytqpy(inb,TRANK) = REAL(rank) cwytqpy(inb,TRCOND) = orthresh 9005 CONTINUE * end of inb loop * * print out reliability data * ========================== * * * print out performance numbers * ============================= * WRITE(uoutfl,1210) DO 810 i = 1,LINRTS WRITE(uoutfl,1230) $ LINNAMES(i), $ lint(i,TIME), $ lint(i,MFLOPS), $ lint(i,MFLOPS), $ int(lint(i,NORUNS)), $ int(lint(i,TRANK)), $ lint(i,TRCOND) WRITE(uoutfl,1220) 810 CONTINUE DO 820 inb = 1,nnb WRITE(uoutfl,1240) $ anb(inb), $ cwytnop(inb,TIME), $ cwytnop(inb,STMFLP), $ cwytnop(inb,RLMFLP), $ int(cwytnop(inb,NORUNS)) 820 CONTINUE WRITE(uoutfl,1220) DO 830 inb = 1,nnb nb = anb(inb) * temp = cwytqpb(inb,RLFLPS) IF( temp.GT.0 ) THEN WRITE(uoutfl,1250)'SGEQPB', $ nb, $ cwytqpb(inb,TIME), $ cwytqpb(inb,STMFLP), $ cwytqpb(inb,RLMFLP), $ int(cwytqpb(inb,NORUNS)), $ int(cwytqpb(inb,TRANK)), $ cwytqpb(inb,TRCOND), $ HUNDRED*cwytqpb(inb,ICFLPS)/temp, $ HUNDRED*cwytqpb(inb,POFLPS)/temp ELSE WRITE(uoutfl,1260)'SGEQPB', $ nb, $ cwytqpb(inb,TIME), $ cwytqpb(inb,STMFLP), $ cwytqpb(inb,RLMFLP), $ int(cwytqpb(inb,NORUNS)), $ int(cwytqpb(inb,TRANK)), $ cwytqpb(inb,TRCOND) END IF * temp = cwytqpx(inb,RLFLPS) IF( temp.GT.0 ) THEN WRITE(uoutfl,1250)'SGEQPX', $ nb, $ cwytqpx(inb,TIME), $ cwytqpx(inb,STMFLP), $ cwytqpx(inb,RLMFLP), $ int(cwytqpx(inb,NORUNS)), $ int(cwytqpx(inb,TRANK)), $ cwytqpx(inb,TRCOND), $ HUNDRED*cwytqpx(inb,ICFLPS)/temp, $ HUNDRED*cwytqpx(inb,POFLPS)/temp ELSE WRITE(uoutfl,1260)'SGEQPX', $ nb, $ cwytqpx(inb,TIME), $ cwytqpx(inb,STMFLP), $ cwytqpx(inb,RLMFLP), $ int(cwytqpx(inb,NORUNS)), $ int(cwytqpx(inb,TRANK)), $ cwytqpx(inb,TRCOND) END IF * temp = cwytqpy(inb,RLFLPS) IF( temp.GT.0 ) THEN WRITE(uoutfl,1250)'SGEQPY', $ nb, $ cwytqpy(inb,TIME), $ cwytqpy(inb,STMFLP), $ cwytqpy(inb,RLMFLP), $ int(cwytqpy(inb,NORUNS)), $ int(cwytqpy(inb,TRANK)), $ cwytqpy(inb,TRCOND), $ HUNDRED*cwytqpy(inb,ICFLPS)/temp, $ HUNDRED*cwytqpy(inb,POFLPS)/temp ELSE WRITE(uoutfl,1260)'SGEQPY', $ nb, $ cwytqpy(inb,TIME), $ cwytqpy(inb,STMFLP), $ cwytqpy(inb,RLMFLP), $ int(cwytqpy(inb,NORUNS)), $ int(cwytqpy(inb,TRANK)), $ cwytqpy(inb,TRCOND) END IF * WRITE(uoutfl,1220) 830 CONTINUE 9004 CONTINUE * end of imode loop 9003 CONTINUE * end of itopt loop 9002 CONTINUE * end of in loop 9001 CONTINUE * end of im loop trt = SECOND() - trt WRITE(uoutfl,1000) trt WRITE(uoutrl,1000) trt WRITE(*,*) ' End of program' CLOSE( uin ) CLOSE( uoutrl ) CLOSE( uoutfl ) STOP * 1000 FORMAT(/,1x,'total run time: ',f8.2,' seconds') 1010 FORMAT(1x,42('*'),/,1x,'* ','time of run: ',a25,' *', $ /,1x,42('*'),/) 1020 FORMAT(1x,f5.3,' minimum time for benchmark run') 1030 FORMAT(1x,4(i5,2x),' seed for RN generator',//) 1040 FORMAT('''',a,'''',' output file') 1050 FORMAT(1x,i3,' strip width') 1060 FORMAT(1x,e8.2,' scale for dependent columns in SQRMTX') 1070 FORMAT(1x,e8.2,' inverse of acceptance threshold') 1080 FORMAT(1x,e8.2,' gap around acceptance threshold') 1090 FORMAT('*** error: iseed(3) = ',i4,' but should be odd') * 1200 FORMAT(/,1x,74('*'),/,1x,'* m:',i4,' n:',i4, $ ' using ',a6,2x,a40,' *', $ /,1x,'* ',16x,'strip: ',i2, $ ' rthresh: ',e8.2,' gap: ',e8.2,11x,' *', $ /,1x,'* ','rank: ',i4,5x,'nobefore: ',i4,5x, $ ' best rcond: ',e8.2,15x, $ ' *',/,1x,'* smax: ',e8.2,' sbefore: ',e8.2, $ ' safter: ',e8.2,' smin: ',e8.2,' *', $ /,1x,'* seed: ',4(i4,2x),41(' '),'*', $ /,1x,74('*')) 1210 FORMAT(/,1x,12x,' | ','time(secs)',' | ','mflops(std)', $ ' | ','mflops(real)',' | ','noruns',' | ', $ 'rank',' | ',' rcond ',' | ','% ice',' | ','%post', $ /,1x,100('=')) 1220 FORMAT(1x,100('-')) 1230 FORMAT(1x,a6,' | ',e8.2,' | ',f7.2,' | ', $ f7.2,' | ',1x,i4,1x,' | ',i4,' | ',e8.2) 1240 FORMAT(1x,'SGEQRF',' nb:',i2,' | ',e8.2, $ ' | ',f7.2,' | ',f7.2,' | ',1x,i4) 1250 FORMAT(1x,a6,' nb:',i2,' | ',e8.2,' | ', $ f7.2,' | ',f7.2,' | ',1x,i4,1x, $ ' | ',i4,' | ',e8.2,' | ',f5.2,' | ',f5.2) 1260 FORMAT(1x,a6,' nb:',i2,' | ',e8.2,' | ', $ f7.2,' | ',f7.2,' | ',1x,i4,1x, $ ' | ',i4,' | ',e8.2) * 1400 FORMAT(/,1x,'SQRDC: ',6x,' svd:',e8.2) 1410 FORMAT(/,1x,'SGEQPF:',6x,' svd:',e8.2,' qrf:',e8.2, $ ' ort:',e8.2) 1420 FORMAT(/,1x,'SGEQRF: nb:',i2,' svd:',e8.2, $ ' qrf:',e8.2,' ort:',e8.2) 1430 FORMAT(1x,'SGEQPB: nb:',i2, $ ' svd:',e8.2,' qrf:',e8.2,' ort:',e8.2) 1440 FORMAT(1x,'SGEQPX: nb:',i2, $ ' svd:',e8.2,' qrf:',e8.2,' ort:',e8.2) 1450 FORMAT(1x,'SGEQPY: nb:',i2, $ ' svd:',e8.2,' qrf:',e8.2,' ort:',e8.2) * * * END SHAR_EOF fi # end of overwriting check if test -f 'sqrmtx.f' then echo shar: will not over-write existing file "'sqrmtx.f'" else cat << SHAR_EOF > 'sqrmtx.f' SUBROUTINE SQRMTX( OPT, SCALE, M, N, RCOND, WIDTH, $ MODE, ISEED, RANK, S, A, LDA, WORK ) * * 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.84 $ * $Date: 96/12/30 16:59:18 $ * CHARACTER*1 OPT INTEGER M, N, WIDTH, LDA, RANK, MODE INTEGER ISEED( 4 ) REAL SCALE, RCOND, A( LDA, * ), S( * ), WORK( * ) * * Purpose: * ======= * * generates a matrix for testing SGEQPF. The independent and * dependent columns of A are arranged in a zebra-like fashion. * That is, if m = 5, n = 12, and width = 2, * columns 1:2 are independent * columns 3:4 are a linear combination of columns 1:2 * columns 5:6 are independent * columns 7:8 are a linear combination of columns 5:6 or * [1:6], depending on the value of 'opt'. * column 9 is independent (there can't be more than * min(m,n) independent columns) * columns 10:12 are again linear combinations of previous * columns * * Arguments: * ========= * * OPT (input) CHARACTER*1 * OPT == 'l' or 'L': dependent columns are linear * combinations of the last set of * independent columns * any other value : dependent columns are linear * combinations of all previous * independent columns * SCALE (input) REAL * dependent columns are a random linear combination of * previous ones multiplied by SCALE. * * M (input) INTEGER * The number of rows of the matrix A. * * N (input) INTEGER * The number of columns of the matrix A. * * RCOND (input) REAL * 1/RCOND is the condition number of the matrix to be * generated. Singular values for the submatrix consisting * of independent columns are generated between * 1 and RCOND dependent on MODE. * * WIDTH (input) INTEGER * The width of a strip of dependent or independent columns. * * MODE (input) INTEGER * is passed to SLATMS to determine how diagonal entries * are generated between 1 and RCOND. * MODE = {-,+}1 : all diagonal entries are RCOND except for * {last,first} one. * MODE = {-,+}2 : all diagonal entries are 1 except for * {first,last} one. * MODE = {-,+}3 : exponentially {declining,increasing} * MODE = {-,+}4 : arithmetically {decl.,incr.} * * ISEED (input/output) INTEGER array, dimension(4) * Seed for random number generator. ISEED(4) must be odd. * * RANK (output) INTEGER * The number of independent columns generated. Note that * this need not necessarily be the numerical rank of A * as determined by the SVD due to the permutation generated * by adding the columns which are linear combinations of * previous ones. * * S (output) REAL array (min(M,N)) * The singular values of A * * A (output) REAL array, dimension (M,N) * matrix with singular value distribution given in S * and pattern of dependent/independent columns determined * by WIDTH. * * LDA (input) INTEGER * leading dimension of A. * * WORK (workspace) REAL array, * dimension max(3*min(m,n),width*width) if OPT == 'L' or 'l' * dimension max(3*min(m,n),width*width*2) otherwise * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. INTEGER MN, WLAST, NSTRPS, INFO, OFFSET, $ NCOLS, CLSLFT, I REAL DUMMY * .. * .. * .. External Subroutines EXTERNAL SLATMS, SLACPY, LSAME, $ SGEBD2, SBDSQR, SLARNV LOGICAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC MIN, MOD, SQRT * .. * .. Executable Statements .. MN = MIN( M, N ) * * How many strips do fit and what is width of last strip? * WLAST = MOD( N, WIDTH ) IF( WLAST.EQ.0 ) THEN NSTRPS = N/WIDTH WLAST = WIDTH ELSE NSTRPS = N/WIDTH + 1 END IF * * What is the rank of A? * IF( MOD( NSTRPS, 2 ).EQ.0 ) THEN RANK = MIN( MN, NSTRPS/2*WIDTH ) ELSE RANK = MIN( MN, (NSTRPS-1)/2*WIDTH + WLAST ) END IF * * How many strips is the matrix of size m -by- rank partitioned into? * WLAST = MOD( RANK, WIDTH ) IF( WLAST.EQ.0 ) THEN NSTRPS = RANK/WIDTH WLAST = WIDTH ELSE NSTRPS = RANK/WIDTH + 1 END IF * * Generate 'rank' independent columns in * A(:,(nstrips-1)*width+1:(nstrips-1)*width+rank)) * OFFSET = ( NSTRPS-1 )*WIDTH CALL SLATMS( M, RANK, 'Uniform', ISEED, 'Nonsymmetric', $ S, MODE, ONE/RCOND, ONE, M, RANK, 'No Packing', $ A( 1, OFFSET+1 ), LDA, WORK, INFO ) IF( INFO.GT.0 ) THEN WRITE(*,999) INFO STOP END IF * * Redistribute independent columns and generate dependent * ones in columns 1 through offset+rank * DO 10 I = 1,NSTRPS-1 CALL SLACPY( 'full matrix', M, WIDTH, $ A( 1, OFFSET+( I-1 )*WIDTH+1 ), LDA, $ A( 1, 2*( I-1 )*WIDTH+1 ),LDA ) IF( LSAME( OPT, 'L' ) ) THEN NCOLS = WIDTH ELSE NCOLS = MIN( 2, I )*WIDTH END IF CALL SLARNV( 1, ISEED, NCOLS*WIDTH, WORK( 1 ) ) CALL SGEMM( 'no transpose', 'no transpose', M, WIDTH, NCOLS, $ SCALE, A( 1, ( 2*I-1 )*WIDTH-NCOLS+1 ), LDA, $ WORK, NCOLS, ZERO, A( 1,( 2*I-1 )*WIDTH+1 ), LDA ) 10 CONTINUE * * generate dependent columns offset+rank+1 through n * CLSLFT = N-( OFFSET+RANK ) IF( CLSLFT.GT.0 ) THEN IF( LSAME( OPT, 'L' ) ) THEN NCOLS = WLAST ELSE NCOLS = MIN( OFFSET+RANK, WLAST+WIDTH ) END IF CALL SLARNV( 1, ISEED, NCOLS*CLSLFT, WORK( 1 ) ) CALL SGEMM( 'no transpose', 'no transpose', M, CLSLFT, NCOLS, $ SCALE, A( 1, OFFSET+RANK+1-NCOLS ), LDA, WORK, $ NCOLS, ZERO,A( 1, OFFSET+RANK+1 ), LDA ) END IF * * compute singular value decomposition of A * CALL SLACPY( 'full matrix', M, N, A, LDA, WORK( MN+1 ), M ) CALL SGEBD2( M, N, WORK( MN+1 ), M, S, WORK( 1 ), $ WORK( MN+M*N+1 ), WORK( 2*MN+M*N+1 ), $ WORK( 3*MN+M*N+1 ), INFO ) CALL SBDSQR( 'upper', MN, 0, 0, 0, S, WORK( 1 ), $ DUMMY, MN, DUMMY, 1, DUMMY, MN, WORK( MN+1 ), INFO ) RETURN 999 FORMAT( '** ERROR in sqrmtx: SLATMS returns INFO = ',i2 ) * * End of SQRMTX * END SHAR_EOF fi # end of overwriting check if test -f 'strqpx.f' then echo shar: will not over-write existing file "'strqpx.f'" else cat << SHAR_EOF > 'strqpx.f' SUBROUTINE STRQPX( JOB, M, N, K, A, LDA, C, LDC, JPVT, IRCOND, $ ORCOND, RANK, SVLUES, WORK, LWORK, 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.84 $ * $Date: 96/12/30 16:59:18 $ * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, RANK, LWORK, INFO REAL IRCOND, ORCOND * .. * .. Array Arguments .. REAL A( LDA, * ), C( LDC, * ), SVLUES( 4 ) REAL WORK( LWORK ) INTEGER JPVT( * ) * .. * * Purpose * ======= * * STRQPX 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 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. 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) REAL 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) REAL array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the orthogonal 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) REAL * 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) REAL * 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) 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) REAL array, dimension ( LWORK ) * * LWORK (input) INTEGER * The dimension of array WORK. LWORK >= MN+MAX(N,2*MN), where * MN = min(M,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, STRQXC, STRRNK * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * MN = MIN( M, N ) NB = ILAENV( INB, 'SGEQRF', ' ', 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 ELSE IF( LWORK.LT.MAX(1,N+3*MN) ) THEN INFO = -15 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'STRQPX', -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 STRRNK( MN, A, LDA, RCOND, RANK, WORK, INFO ) * * ************************ * * First call to xTRQXC * * ************************ * * Get tighter bounds for the value RANK. * CALL STRQXC( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ RANK, SVLUES, RCNR, RCNRP1, WORK, 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 STRQXC( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ RANK, SVLUES, RCNR, RCNRP1, WORK, 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 STRQPX * END SHAR_EOF fi # end of overwriting check if test -f 'strqpy.f' then echo shar: will not over-write existing file "'strqpy.f'" else cat << SHAR_EOF > 'strqpy.f' SUBROUTINE STRQPY( JOB, M, N, K, A, LDA, C, LDC, JPVT, IRCOND, $ ORCOND, RANK, SVLUES, WORK, LWORK, 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.84 $ * $Date: 96/12/30 16:59:19 $ * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, RANK, LWORK, INFO REAL IRCOND, ORCOND * .. * .. Array Arguments .. REAL A( LDA, * ), C( LDC, * ), SVLUES( 4 ) REAL WORK( LWORK ) INTEGER JPVT( * ) * .. * * Purpose * ======= * * STRQPY 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 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. 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) REAL 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) REAL array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the orthogonal 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) REAL * 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) REAL * 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) REAL array, dimension ( LWORK ) * * LWORK (input) INTEGER * The dimension of array WORK. LWORK >= N+3*MN, where * MN = min(M,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, STRQYC, STRRNK * .. * .. Intrinsic Functions .. INTRINSIC MIN, MAX * .. * .. Executable Statements .. * MN = MIN( M, N ) NB = ILAENV( INB, 'SGEQRF', ' ', 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 ELSE IF( LWORK.LT.MAX(1,N+3*MN) ) THEN INFO = -15 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'STRQPY', -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 STRRNK( MN, A, LDA, RCOND, RANK, WORK, INFO ) * * ************************ * * First call to xTRQYC * * ************************ * * Get tighter bounds for the value RANK. * CALL STRQYC( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ RANK, SVLUES, RCNR, RCNRP1, WORK, 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 STRQYC( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ RANK, SVLUES, RCNR, RCNRP1, WORK, 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 STRQPY * END SHAR_EOF fi # end of overwriting check if test -f 'strqxc.f' then echo shar: will not over-write existing file "'strqxc.f'" else cat << SHAR_EOF > 'strqxc.f' SUBROUTINE STRQXC( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ RANK, SVLUES, RCNR, RCNRP1, WORK, 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.84 $ * $Date: 96/12/30 16:59:20 $ * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, RANK, INFO REAL RCNR, RCNRP1 * .. * .. Array Arguments .. REAL A( LDA, * ), C( LDC, * ), WORK( * ), $ SVLUES( 4 ) INTEGER JPVT( * ) * .. * * Purpose * ======= * * STRQXC 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 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. 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) REAL 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) REAL array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the orthogonal 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 * Th 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) 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 * Th estimate for the inverse of the condition number of block * R(1:RANK,1:RANK). * * RCNRP1 (output) REAL * Th estimate for the inverse of the condition number of block * R(1:RANK+1,1:RANK+1). * * WORK (workspace) REAL array, * dimension ( MN+MAX(N,2*MN) ), where MN=MIN(M,N). * * INFO (output) INTEGER * = 0: Successful exit. * < 0: If info = -i, the i-th argument had an illegal value. * = 1: Exceeded the allowed maximum number of steps. That is, * the matrix presents a slow convergence. * * * =================================================================== * * .. Parameters .. REAL ONE, F PARAMETER ( F = 0.5E+0, ONE = 1.0E+0 ) * * Indices into the 'svlues' array. * INTEGER IMAX, IBEFOR, IAFTER, IMIN PARAMETER ( IMAX = 1, IBEFOR = 2, IAFTER = 3, IMIN = 4 ) * .. * .. Local Scalars .. REAL COSINE, SINE, SMAX, SMAXPR, SMIN, SMINPR, $ SMXRP1 LOGICAL PERMUT INTEGER J, MN, MXSTPS, NACPTD INTEGER NS * .. * .. External Subroutines .. EXTERNAL SSCAL * .. * .. External Functions .. INTEGER ISAMAX REAL SLASMX, SNRM2 EXTERNAL ISAMAX, SLASMX, SNRM2 * .. * .. 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 WORK(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 WORK( J ) = SNRM2( 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 SGLBIF( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ F, RANK, PERMUT, WORK( MN+1 ), INFO ) * * If necessary, update the contents of WORK(RANK). * IF( PERMUT ) $ WORK( RANK ) = SNRM2( 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 SGLBIF( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ F, RANK+1, PERMUT, WORK( 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. * WORK( RANK+1 ) = SNRM2( 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 SCNIIF( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ WORK, F, RANK+1, PERMUT, WORK( 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 SCNIIF( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ WORK, F, RANK, PERMUT, WORK( 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 vector SVLUES and variables RCNR and RCNRP1 * * ************************************************************** * * Computation of the largest singular value and the smallest * singular value of A(1:RANK,1:RANK). * SMAX = ABS( A( 1, 1 ) ) WORK( 1 ) = ONE SMIN = SMAX WORK( MN+1 ) = ONE * DO 30 J = 2, RANK CALL SLAIC1( 1, J-1, WORK( 1 ), SMAX, $ A( 1, J ), A( J, J ), SMAXPR, SINE, COSINE ) CALL SSCAL( J-1, SINE, WORK( 1 ), 1 ) WORK( J ) = COSINE SMAX = SMAXPR CALL SLAIC1( 2, J-1, WORK( MN+1 ), SMIN, $ A( 1, J ), A( J, J ), SMINPR, SINE, COSINE ) CALL SSCAL( 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 SLAIC1( 1, RANK, WORK( 1 ), SMAX, $ A( 1, RANK+1 ), A( RANK+1, RANK+1 ), SMAXPR, $ SINE, COSINE ) SMAX = SMAXPR CALL SLAIC1( 2, RANK, WORK( MN+1 ), SMIN, $ A( 1, RANK+1 ), A( RANK+1, RANK+1 ), SMINPR, $ SINE, COSINE ) CALL SSCAL( 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 SLAIC1( 2, J-1, WORK( MN+1 ), SMIN, $ A( 1, J ), A( J, J ), SMINPR, SINE, COSINE ) CALL SSCAL( 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 STRQXC * END SUBROUTINE SGLBIF( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ F, RANK, PERMUT, WORK, INFO ) * * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, RANK, INFO REAL F LOGICAL PERMUT * .. * .. Array Arguments .. REAL A( LDA, * ), C( LDC, * ), WORK( * ) INTEGER JPVT( * ) * .. * * Purpose * ======= * * SGLBIF 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 and permuts and retriangularizes * matrix A. It does only one permutation. * * 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. 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) REAL 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) REAL array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the orthogonal 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 * Th estimate for the rank. 1 <= RANK <= MIN(M,N). * * PERMUT (output) LOGICAL * Tells if a permutation occurred. * * WORK (workspace) REAL array, * dimension ( MAX( N, 2*MIN(M,N) ) ) * * INFO (output) INTEGER * = 0: Successful exit. * < 0: If info = -i, the i-th argument had an illegal value. * * ===================================================================== * * .. Local Scalars .. INTEGER MN, JJ, J, ITEMP * .. * .. Local Arrays .. REAL RDUMMY( 1, 1 ) * .. * .. External Subroutines .. EXTERNAL SCOPY, SGRET * .. * .. External Functions .. INTEGER ISAMAX REAL SNRM2 EXTERNAL ISAMAX, SNRM2 * .. * .. Executable Statements .. * MN = MIN( M, N ) INFO = 0 * * Quick return if possible. * IF( ( MN.EQ.0 ).OR.( RANK.EQ.N ).OR.( RANK.EQ.0 ) ) THEN PERMUT = .FALSE. RETURN END IF * * Compute the norms of the columns of block A(RANK:M,RANK:N) * and store them in vector WORK(RANK:N). * DO 10 J = RANK, N WORK( J ) = $ SNRM2( 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 WORK(RANK:N). * JJ = RANK - 1 + ISAMAX( N-RANK+1, WORK( RANK ), 1) * * Determine if a permutation must occur. * PERMUT = ( ( JJ.GT.RANK ).AND. $ ( ( ABS( WORK( JJ ) )*F ).GT.ABS( WORK( 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 SCOPY( MIN( MN, JJ ), A( 1, JJ ), 1, WORK, 1 ) DO 20 J = JJ-1, RANK, -1 CALL SCOPY( MIN( MN, J+1 ), A( 1, J ), 1, $ A( 1, J+1 ), 1 ) 20 CONTINUE CALL SCOPY( 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 SGRET( JOB, MIN( M, JJ )-RANK+1, N-RANK+1, K, $ A( RANK, RANK ), LDA, RDUMMY, 1, $ WORK, INFO ) ELSE IF( JOB.EQ.2 ) THEN CALL SGRET( JOB, MIN( M, JJ )-RANK+1, N-RANK+1, K, $ A( RANK, RANK ), LDA, C( RANK, 1 ), LDC, $ WORK, INFO ) ELSE IF( JOB.EQ.3 ) THEN CALL SGRET( JOB, MIN( M, JJ )-RANK+1, N-RANK+1, K, $ A( RANK, RANK ), LDA, C( 1, RANK ), LDC, $ WORK, INFO ) END IF END IF RETURN * * End of SGLBIF * END SUBROUTINE SCNIIF( JOB, M, N, K, A, LDA, C, LDC, JPVT, VNORM, $ F, RANK, PERMUT, WORK, INFO ) * * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, RANK, INFO REAL F LOGICAL PERMUT * .. * .. Array Arguments .. REAL A( LDA, * ), C( LDC, * ), VNORM( * ), WORK( * ) INTEGER JPVT( * ) * .. * * Purpose * ======= * * SCNIIF 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 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. 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) REAL 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) REAL array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the orthogonal 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 * Th estimate for the rank. 1 <= RANK <= MIN(M,N). * * PERMUT (output) LOGICAL * Tells if a permutation occurred. * * WORK (workspace) REAL array, dimension ( 2*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, ONE PARAMETER ( SF = 1.0E+2, ONE = 1.0E+0 ) * .. * .. Local Scalars .. INTEGER MN, JJ, J, ITEMP REAL SMAX, SMIN, SMINPR, SINE, COSINE, TEMP , $ RDUMMY( 1 ) * .. * .. External Subroutines .. EXTERNAL SCOPY, STRSV, SHESS * .. * .. External Functions .. INTEGER ISAMAX REAL SNRM2, SLAMCH, SLASMX EXTERNAL ISAMAX, SNRM2, 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 ) = ONE DO 10 J = 2, RANK CALL SLAIC1( 2, J-1, WORK( 1 ), SMIN, A( 1, J ), $ A( J , J ), SMINPR, SINE, COSINE ) CALL SSCAL( 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 put into vector * WORK(1:RANK). * CALL STRSV( 'Upper', 'No transpose', 'No unit', $ RANK, A, LDA, WORK, 1) * * Find the index with largest absolute value in vector * WORK(1:RANK). * JJ = ISAMAX( 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 SCOPY( RANK, A( 1, JJ ), 1, WORK, 1 ) DO 20 J = JJ+1, RANK CALL SCOPY( J, A( 1, J ), 1, A( 1, J-1 ), 1 ) 20 CONTINUE CALL SCOPY( 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 SHESS( JOB, RANK-JJ+1, N-JJ+1, K, $ A( JJ, JJ ), LDA, RDUMMY, 1, $ WORK, INFO ) ELSE IF( JOB.EQ.2 ) THEN CALL SHESS( JOB, RANK-JJ+1, N-JJ+1, K, $ A( JJ, JJ ), LDA, C( JJ, 1 ), LDC, $ WORK, INFO ) ELSE IF( JOB.EQ.3 ) THEN CALL SHESS( JOB, RANK-JJ+1, N-JJ+1, K, $ A( JJ, JJ ), LDA, C( 1, JJ ), LDC, $ WORK, INFO ) END IF END IF END IF RETURN * * End of SCNIIF * END SUBROUTINE SGRET( JOB, M, N, K, A, LDA, C, LDC, WORK, INFO ) * * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, INFO * .. * .. Array Arguments .. REAL A( LDA, * ), C( LDC, * ), WORK( * ) * .. * * Purpose * ======= * * SGRET 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 orthogonal transformations applied to matrix A can be also * applied to matrix C. * * Parameters * ========== * * 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. 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) REAL 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) REAL array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the orthogonal 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) REAL array, dimension ( 2*M ) * If the block algorithm is used, the size of this workspace * must be ( 2*M ). * In this case this vector will contain the sines and cosines * of the angles of the Givens Rotations to be applied. * * INFO (output) INTEGER * = 0: Successful exit. * < 0: If info = -i, the i-th argument had an illegal value. * * ===================================================================== * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E+0 ) * .. * .. Common Blocks .. INTEGER NB COMMON /BSPRQR/ NB * .. * .. Local Scalars .. INTEGER I, J, JB, ITEMP REAL R, COSINE, SINE * .. * .. External Subroutines .. EXTERNAL SLARTG, SROT * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. 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 vector WORK. * DO 10 I = M, 2, -1 CALL SLARTG( A( I-1, 1 ), A( I, 1 ), $ WORK( I ), WORK( M+I ), R ) A( I-1, 1 ) = R A( I, 1 ) = ZERO 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 SROT( J+JB-I, A( I-1, I ), LDA, A( I, I ), LDA, $ WORK( I ), WORK( M+I ) ) 30 CONTINUE DO 40 I = MIN( M, J-1 ), 2, -1 CALL SROT( JB, A( I-1, J ), LDA, A( I, J ), LDA, $ WORK( I ), WORK( M+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 SROT( JB, C( I-1, J ), LDC, C( I, J ), LDC, $ WORK( I ), WORK( M+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 SROT( K, C( 1, I-1 ), 1, C( 1, I ), 1, $ WORK( I ), WORK( M+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 SLARTG( A( ITEMP, 1 ), A( I , 1 ), COSINE, SINE, R ) A( ITEMP, 1 ) = R A( I, 1 ) = ZERO * * Update columns I:N of matrix A. * CALL SROT( 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 SROT( 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 SROT( K, C( 1, ITEMP ), 1, C( 1, I ), 1, $ COSINE, SINE ) END IF 90 CONTINUE END IF RETURN * * End of SGRET * END SUBROUTINE SHESS( JOB, M, N, K, A, LDA, C, LDC, WORK, INFO ) * * * .. Scalar Arguments .. INTEGER JOB, M, N, K, LDA, LDC, INFO * .. * .. Array Arguments .. REAL A( LDA, * ), C( LDC, * ), WORK( * ) * .. * * Purpose * ======= * * SHESS 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 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. 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) REAL 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) REAL array, dimension * ( LDC, K ) if JOB=2. * ( LDC, M ) if JOB=3. * If argument JOB asks, all the orthogonal 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) REAL array, dimension ( 2*M ) * If the block algorithm is used, the size of this workspace * must be ( 2*M ). * In this case this vector will contain the sines and cosines * of the angles of the Givens Rotations to be applied. * * INFO (output) INTEGER * = 0: Successful exit. * < 0: If info = -i, the i-th argument had an illegal value. * * ===================================================================== * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E+0 ) * .. * .. Common Blocks .. INTEGER NB COMMON /BSPRQR/ NB * .. * .. Local Scalars .. INTEGER I, J, ITEMP, JB REAL R, COSINE, SINE * .. * .. External Subroutines .. EXTERNAL SLARTG, SROT * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. 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 vector WORK. * DO 10 J = 1, N, NB JB = MIN( NB, N-J+1 ) DO 20 I = 2, MIN( M, J ) CALL SROT( JB, A( I-1, J ), LDA, A( I, J ), LDA, $ WORK( I ), WORK( M+I ) ) 20 CONTINUE DO 30 I = J+1, MIN( M, J+JB ) ITEMP = I-1 CALL SLARTG( A( ITEMP, ITEMP ), A( I, ITEMP ), $ WORK( I ), WORK( M+I ), R ) A( ITEMP, ITEMP ) = R A( I, ITEMP ) = ZERO CALL SROT( J+JB-I, A( ITEMP, I ), LDA, $ A( I, I ), LDA, $ WORK( I ), WORK( M+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 SROT( JB, C( I-1, J ), LDC, C( I, J ), LDC, $ WORK( I ), WORK( M+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 SROT( K, C( 1, I-1 ), 1, C( 1, I ), 1, $ WORK( I ), WORK( M+I ) ) 60 CONTINUE END IF ELSE * * Non-Block Algorithm * =================== * DO 80 I = 2, M ITEMP = I - 1 * * Compute the rotation parameters. * CALL SLARTG( A( ITEMP, ITEMP ), A( I, ITEMP ), $ COSINE, SINE, R ) * * Update columns I-1:N of matrix A. * A( ITEMP, ITEMP ) = R A( I, ITEMP ) = ZERO CALL SROT( 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 SROT( 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 SROT( K, C( 1, ITEMP ), 1, C( 1, I ), 1, $ COSINE, SINE ) END IF 80 CONTINUE END IF RETURN * * End of SHESS * END SHAR_EOF fi # end of overwriting check if test -f 'strqyc.f' then echo shar: will not over-write existing file "'strqyc.f'" else cat << SHAR_EOF > 'strqyc.f' SUBROUTINE STRQYC( JOB, M, N, K, A, LDA, C, LDC, JPVT, $ RANK, SVLUES, RCNR, RCNRP1, WORK, 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.84 $ * $Date: 96/12/30 16:59:21 $ * * .. Scalars Arguments .. INTEGER JOB, M, N, K, LDA, LDC, RANK, INFO REAL RCNR, RCNRP1 * .. * .. Array Arguments .. REAL A( LDA, * ), C( LDC, * ), WORK( * ), $ SVLUES( 4 ) INTEGER JPVT( * ) * .. * * Purpose * ======= * * STRQYC 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) REAL 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) REAL 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) REAL array, dimension (N+3*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, ONE PARAMETER ( FP = 0.9E+0, SF = 1.0E+2, ONE = 1.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 COSINE, DIAG, F, SMAX, SMAXPR, SMIN, SMINPR, $ SMNRP1, SMXRP1, SINE, TEMP INTEGER NS * .. * .. Local Arrays .. REAL RDUMMY( 1, 1 ) * .. * .. External Subroutines .. EXTERNAL SSCAL, SLAIC1, STRSV, SLARTG, $ SGRET, SHESS, SSWAP, SCOPY * .. * .. External Functions .. EXTERNAL ISAMAX, SNRM2, SLASMX, SLAMCH INTEGER ISAMAX REAL SNRM2, SLASMX, SLAMCH * .. * .. Intrinsic Functions .. INTRINSIC ABS, SQRT, REAL, MAX, MIN * .. * .. 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( 'STRQYC', -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 + ISAMAX( N-MN+1, A( MN, MN ), LDA ) IF( JJ.GT.MN ) THEN CALL SSWAP( 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 ) = ONE SMIN = SMAX WORK( MN+1 ) = ONE DO 10 J = 2, RANK CALL SLAIC1( 1, J-1, WORK( 1 ), SMAX, A( 1, J ), $ A( J, J ), SMAXPR, SINE, COSINE ) CALL SSCAL( J-1, SINE, WORK( 1 ), 1 ) WORK( J ) = COSINE SMAX = SMAXPR * CALL SLAIC1( 2, J-1, WORK( MN+1 ), SMIN, A( 1, J ), $ A( J, J ), SMINPR, SINE, COSINE ) CALL SSCAL( 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 STRSV( '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 = ISAMAX( 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 SCOPY( RANK, A( 1, JJ ), 1, WORK( 1 ), 1 ) DO 20 J = JJ+1, RANK CALL SCOPY( J, A( 1, J ), 1, A( 1, J-1 ), 1 ) 20 CONTINUE CALL SCOPY( 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 SHESS( JOB, RANK-JJ+1, N-JJ+1, K, $ A( JJ, JJ ), LDA, RDUMMY, 1, $ WORK( 1 ), INFO ) ELSE IF( JOB.EQ.2 ) THEN CALL SHESS( JOB, RANK-JJ+1, N-JJ+1, K, $ A( JJ, JJ ), LDA, C( JJ, 1 ), LDC, $ WORK( 1 ), INFO ) ELSE IF( JOB.EQ.3 ) THEN CALL SHESS( JOB, RANK-JJ+1, N-JJ+1, K, $ A( JJ, JJ ), LDA, C( 1, JJ ), LDC, $ WORK( 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 WORK(1:N). * DO 100 J = 1, N WORK( J ) = SNRM2( 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(N+1:N+MN) will contain the left singular vector. * SMIN = ABS( A( 1, 1 ) ) WORK( N+1 ) = ONE DO 110 J = 2, RANK CALL SLAIC1( 2, J-1, WORK( N+1 ), SMIN, A( 1, J ), $ A( J , J ), SMINPR, SINE, COSINE ) CALL SSCAL( J-1, SINE, WORK( N+1 ), 1 ) WORK( N+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 SLARTG( A( I, II ), DIAG, COSINE, SINE, TEMP ) DIAG = TEMP 120 CONTINUE * CALL SLAIC1( 2, RANK, WORK( N+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 SCOPY( MIN( MN, II ), A( 1, II ), 1, $ WORK( N+MN+1 ), 1 ) DO 130 J = II-1, RANK+1, -1 CALL SCOPY( MIN( MN, J+1 ), A( 1, J ), 1 , $ A( 1, J+1 ), 1 ) 130 CONTINUE CALL SCOPY( MIN( MN, II ), WORK( N+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 WORK(1:N). * TEMP = WORK( II ) DO 150 J = II-1, RANK+1, -1 WORK( J+1 ) = WORK( J ) 150 CONTINUE WORK( RANK+1 ) = TEMP * * Retriangularize matrix A after permutation. * IF( JOB.EQ.1 ) THEN CALL SGRET( JOB, MIN( M, II )-RANK, N-RANK, K, $ A( RANK+1, RANK+1 ), LDA, RDUMMY, 1, $ WORK( N+MN+1 ), INFO ) ELSE IF( JOB.EQ.2 ) THEN CALL SGRET( JOB, MIN( M, II )-RANK, N-RANK, K, $ A( RANK+1, RANK+1 ), LDA, C( RANK+1, 1 ), $ LDC, WORK( N+MN+1 ), INFO ) ELSE IF( JOB.EQ.3 ) THEN CALL SGRET( JOB, MIN( M, II )-RANK, N-RANK, K, $ A( RANK+1, RANK+1 ), LDA, C( 1, RANK+1 ), $ LDC, WORK( N+MN+1 ), INFO ) END IF * * *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* * * Estimate the largest singular value * * *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* * ITEMP = ISAMAX( RANK+1, WORK, 1 ) SMXRP1 = SLASMX( RANK+1 )*WORK( 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. * CALL SCOPY( RANK, WORK( N+1 ), 1, WORK( N+MN+1 ), 1 ) CALL SSCAL( RANK, SINE, WORK( N+MN+1 ), 1 ) WORK( N+MN+RANK+1 ) = COSINE * * Obtain the right singular vector from the left one. * CALL STRSV( 'Upper', 'No transpose', 'No unit', $ RANK+1, A, LDA, WORK( N+MN+1 ), 1 ) * JJ = ISAMAX( RANK+1, WORK( N+MN+1 ), 1 ) * * *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* * * Permut column JJ to position RANK+1 * * *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* * IF( JJ.LT.( RANK+1 ) ) THEN * * Exchange cyclically to the left the columns of A * between JJ and RANK+1, that is, JJ->RANK+1,JJ+1->JJ, * JJ+2->JJ+1,...,RANK+1->RANK. * CALL SCOPY( RANK+1, A( 1, JJ ), 1, $ WORK( N+MN+1 ), 1 ) DO 160 J = JJ+1, RANK+1 CALL SCOPY( J, A( 1, J ), 1, $ A( 1, J-1 ), 1 ) 160 CONTINUE CALL SCOPY( RANK+1, WORK( N+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 WORK. * TEMP = WORK( JJ ) DO 180 J = JJ+1, RANK+1 WORK( J-1 ) = WORK( J ) 180 CONTINUE WORK( RANK+1 ) = TEMP * * Retriangularize matrix A after the permutation. * IF( JOB.EQ.1 ) THEN CALL SHESS( JOB, RANK-JJ+2, N-JJ+1, K, $ A( JJ, JJ ), LDA, RDUMMY, 1, $ WORK( N+MN+1 ), INFO ) ELSE IF( JOB.EQ.2 ) THEN CALL SHESS( JOB, RANK-JJ+2, N-JJ+1, K, $ A( JJ, JJ ), LDA, C( JJ, 1 ), LDC, $ WORK( N+MN+1 ), INFO ) ELSE IF( JOB.EQ.3 ) THEN CALL SHESS( JOB, RANK-JJ+2, N-JJ+1, K, $ A( JJ, JJ ), LDA, C( 1, JJ ), LDC, $ WORK( N+MN+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(N+1:N+MN) will contain the left singular * vector. * SMIN = ABS( A( 1, 1 ) ) WORK( N+1 ) = ONE DO 190 J = 2, RANK CALL SLAIC1( 2, J-1, WORK( N+1 ), SMIN, $ A( 1, J ), A( J , J ), SMINPR, $ SINE, COSINE ) CALL SSCAL( J-1, SINE, WORK( N+1 ), 1 ) WORK( N+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, WORK( RANK+1 ), 1 ) IF( ( JJ.GT.( RANK+1 ) ).AND. $ ( F*ABS( WORK( JJ ) ).GT.ABS( WORK( RANK+1 ) ) ) ) THEN * * Exchange column JJ to position RANK+1. * CALL SCOPY( MIN( MN, JJ ), A( 1, JJ ), 1, $ WORK( N+MN+1 ), 1 ) DO 200 J = JJ-1, RANK+1, -1 CALL SCOPY( MIN( MN, J+1 ), A( 1, J ), 1 , $ A( 1, J+1 ), 1 ) 200 CONTINUE CALL SCOPY( MIN( MN, JJ ), WORK( N+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 SGRET( JOB, MIN( M, JJ )-RANK, N-RANK, K, $ A( RANK+1, RANK+1 ), LDA, RDUMMY, 1, $ WORK( N+MN+1 ), INFO ) ELSE IF( JOB.EQ.2 ) THEN CALL SGRET( JOB, MIN( M, JJ )-RANK, N-RANK, K, $ A( RANK+1, RANK+1 ), LDA, C( RANK+1, 1 ), $ LDC, WORK( N+MN+1 ), INFO ) ELSE IF( JOB.EQ.3 ) THEN CALL SGRET( JOB, MIN( M, JJ )-RANK, N-RANK, K, $ A( RANK+1, RANK+1 ), LDA, C( 1, RANK+1 ), $ LDC, WORK( N+MN+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( 1 ) = ONE * DO 220 J = 2, RANK CALL SLAIC1( 1, J-1, WORK( 1 ), SMAX, $ A( 1, J ), A( J, J ), SMAXPR, SINE, COSINE ) CALL SSCAL( J-1, SINE, WORK( 1 ), 1 ) WORK( 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 SLAIC1( 1, RANK, WORK( 1 ), SMAX, $ A( 1, RANK+1 ), A( RANK+1, RANK+1 ), SMXRP1, $ SINE, COSINE ) CALL SLAIC1( 2, RANK, WORK( N+1 ), SMIN, $ A( 1, RANK+1 ), A( RANK+1, RANK+1 ), SMINPR, $ SINE, COSINE ) CALL SSCAL( RANK, SINE, WORK( N+1 ), 1 ) WORK( N+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 SLAIC1( 2, J-1, WORK( N+1 ), SMIN, $ A( 1, J ), A( J, J ), SMINPR, SINE, COSINE ) CALL SSCAL( J-1, SINE, WORK( N+1 ), 1 ) WORK( N+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 ) $ INFO = 1 END IF RETURN * * End of STRQYC * END SHAR_EOF fi # end of overwriting check if test -f 'strrnk.f' then echo shar: will not over-write existing file "'strrnk.f'" else cat << SHAR_EOF > 'strrnk.f' SUBROUTINE STRRNK( N, R, LDR, RCOND, RANK, WORK, INFO ) * * $Revision: 1.84 $ * $Date: 96/12/30 16:59:21 $ * * .. Scalar Arguments .. INTEGER LDR, N, RANK, INFO REAL RCOND * .. * .. Array Arguments .. REAL R( LDR, * ), WORK( * ) * * Purpose * ======= * * STRRNK 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) REAL 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) 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 ONE, ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) * .. * .. Local Scalars .. INTEGER I REAL C1, C2, SMAX, SMAXPR, SMIN, SMINPR, S1, S2 * .. * .. External Subroutines .. EXTERNAL SLAIC1 * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. 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( 'STRRNK', -INFO ) RETURN END IF * * Determine RANK using incremental condition estimation. * WORK( 1 ) = ONE WORK( N+1 ) = ONE 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 SLAIC1( 2, RANK, WORK, SMIN, R( 1, I ), $ R( I, I ), SMINPR, S1, C1 ) CALL SLAIC1( 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 STRRNK * END SHAR_EOF fi # end of overwriting check if test -f 'sutils.f' then echo shar: will not over-write existing file "'sutils.f'" else cat << SHAR_EOF > 'sutils.f' * * 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.84 $ * $Date: 96/12/30 16:59:22 $ * ********************************************************************* INTEGER FUNCTION flXGEQPF( m, n ) INTEGER m, n * returns flop count for xgeqpf (lapack routine with column * pivoting) INTEGER tflops, i * initialize column norms tflops = 3*n+1 DO 10 i =1,min(m,n) * find pivot column and update partial column norms tflops = tflops + 10*(n-i) * compute HH vector tflops = tflops + 3*(m-i+1)+6 * update remaining submatrix tflops = tflops + 4*(m-i+1)*(n-i)+3*(n-i) 10 CONTINUE flXGEQPF = tflops RETURN END ********************************************************************* INTEGER FUNCTION flXGEQR2(m,n) INTEGER m, n * returns flop count for xgeqr2 (lapack blas 2 routine for * QR factorization without column exchanges) INTEGER i, tflops tflops = 0 DO 10 i =1,min(m,n) * compute HH vector tflops = tflops + 3*(m-i+1)+6 * update remaining submatrix tflops = tflops + 4*(m-i+1)*(n-i)+3*(n-i) 10 CONTINUE flXGEQR2 = tflops RETURN END ********************************************************************* INTEGER FUNCTION flXLARFT(m,nb) INTEGER m, nb * returns flop count for slarft (generation of a block * reflector) INTEGER i, tflops tflops = 0 DO 10 i = 2, nb * flops for SGEMV tflops = tflops + 2*(m-i+1)*(i-1)+2*(i-1) * flops for STRMV tflops = tflops + (i-1)*(i-1)+2*(i-1) 10 CONTINUE flXLARFT = tflops RETURN END ********************************************************************* INTEGER FUNCTION flXLARFB(m,n,nb) INTEGER m, n, nb * returns flop count for applying a m by nb block reflector * from the left to a m by n matrix INTEGER t * XGEMM t = nb*(2*m*n + 2*n) * XTRMM t = t + n*nb*nb * XGEMM t = t + n*(2*m*nb+nb) flXLARFB = t RETURN END ******************************************************************* INTEGER FUNCTION flXGEQRF(m,n,nb) INTEGER m, n, nb * returns flop count for blocked QR factorization without * column exchanges INTEGER i, t, kb EXTERNAL flXGEQR2, flXLARFT, flXLARFB INTEGER flXGEQR2, flXLARFT, flXLARFB t = 0 DO 10 i = 1,min(m,n),nb kb = min(min(m,n)-i+1,nb) t = t + flXGEQR2(m-i+1,kb) $ + flXLARFT(m-i+1,kb) $ + flXLARFB(m-i+1,n-i-kb+1,kb) 10 CONTINUE flXGEQRF = t RETURN END ********************************************************************* SUBROUTINE SZLTRI( m, n, a, lda ) * zeroes lower triangle of m-by-n matrix A INTEGER m, n, lda REAL a( lda, n ) REAL ZERO PARAMETER ( ZERO = 0.0E+0 ) INTEGER i, j DO 10 j = 1, n DO 20 i = j+1, m a(i,j) = ZERO 20 CONTINUE 10 CONTINUE RETURN END ********************************************************************* INTEGER FUNCTION flXLAIC1(j) INTEGER j * flops for incremental condition estimation excluding * construction of nullvector flXLAIC1 = 43 + 2*j RETURN END ********************************************************************* LOGICAL FUNCTION iscle(vname,var,bound) * INTEGER scalar 'var' less equal 'bound' ? CHARACTER*(*) vname INTEGER var, bound IF( ABS(var) .gt. bound) then WRITE(*,1000) vname,var,bound iscle = .false. ELSE iscle = .true. END IF RETURN 1000 FORMAT(/,1x,a,' = ',i6,' > bound = ',i6) END ********************************************************************* LOGICAL FUNCTION iarle(vname,var,length,bound) * INTEGER array 'var' less equal 'bound' ? CHARACTER*(*) vname INTEGER length, var(length), bound, i DO 10 i = 1,length IF( ABS(var(i)) .gt. bound) then WRITE(*,1000) vname,i,ABS(var(i)), bound iarle = .false. RETURN END IF 10 CONTINUE iarle = .true. RETURN 1000 FORMAT(/,1x,a,'(',i3,') = ',i6,' > bound = ',i6) END ********************************************************************* REAL FUNCTION Sckqrf( m, n, qt, ldqt, r, ldr, $ a, lda, jpvt, work ) INTEGER m,n,ldqt,ldr,lda REAL qt(ldqt,m),r(ldr,n),a(lda,n),work(m) INTEGER jpvt(n) * * This code computes the frobenius norm of Q'*A*P-R, * where permutation matrix P is defined by jpvt. * REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) EXTERNAL Sgemv, Snrm2 REAL Snrm2 INTRINSIC sqrt,min INTEGER i, j REAL aux aux = ZERO DO 10 j = 1, n * Store j-th column of R in vector work. DO 20 i = 1, min(m,j) work(i) = r(i,j) 20 CONTINUE DO 30 i = j+1, m work(i) = ZERO 30 CONTINUE * Substract j-th column of Q'*A*P and j-th column of R. CALL Sgemv('No transpose',m,m,-ONE,qt,ldqt,a(1,jpvt(j)),1, $ ONE,work,1) * Accumulate the residuals. aux = aux + Snrm2(m,work,1) ** 2 10 CONTINUE Sckqrf = sqrt(aux) RETURN END ******************************************************************* REAL FUNCTION Sckort( m, n, q, ldq, work ) INTEGER m,n,ldq REAL q(ldq,n), work(n) * * Checks for orthogonality of matrix Q with orthogonal columns. * It computes the frobenius norm of Q'*Q-In, where Q is m by n, * Q' is the transpose of Q and In is n by n identity matrix. * REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) EXTERNAL Sgemv, Snrm2 REAL Snrm2 INTRINSIC sqrt INTEGER i,j REAL aux aux = ZERO DO 10 j = 1, n * Assign j-th column of In (n by n identity matrix) to vector work. DO 20 i = 1, n work(i) = ZERO 20 CONTINUE work(j) = ONE * Compute work:= work - Q'*Q(:,j). CALL Sgemv('Transpose',m,n,-ONE,q,ldq,q(1,j),1, $ ONE,work,1) * Accumulate the residuals. aux = aux + Snrm2(n,work,1) ** 2 10 CONTINUE Sckort = sqrt(aux) RETURN END ******************************************************************* REAL FUNCTION Scksvd( m, n, a, lda, svlues, $ work1,work2) INTEGER m, n, lda REAL a(lda,*), svlues(*),work1(m,*), $ work2(*) * * compares the singular values s of the upper triangle of A * with the values in svlues and returns * || s - svlues||/||svlues|| * REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) INTEGER i, j, info, mn REAL dummy, nrmsvl EXTERNAL Sgebd2, Sbdsqr, Saxpy, Snrm2 REAL Snrm2 mn = min( m, n ) nrmsvl = Snrm2(mn,svlues,1) IF( nrmsvl .eq. ZERO) nrmsvl = ONE * * Copy upper triangle of A into work1 * DO 10 j = 1, n DO 20 i = 1, min( j, m ) work1( i, j ) = a( i, j ) 20 CONTINUE DO 30 i = j+1,m work1(i,j) = ZERO 30 CONTINUE 10 CONTINUE * * compute SVD of work1 * CALL Sgebd2(m,n,work1,m,work2(1),work2(mn+1),work2(2*mn+1), $ work2(3*mn+1),work2(4*mn+1),info) CALL Sbdsqr('upper',mn,0,0,0,work2(1),work2(mn+1),dummy,mn, $ dummy,1,dummy,mn,work1(1,1),info) * * compare svlues and work1 * CALL Saxpy(mn,-ONE,svlues,1,work2,1) Scksvd = Snrm2(mn,work2,1)/nrmsvl RETURN END ********************************************************************* REAL FUNCTION Sckpqr(m,n,k,qr,ldq,tau,a,lda, $ jpvt,work) INTEGER m,n,k,lda,ldq REAL qr(ldq,n),tau(n),a(lda,n),work(*) INTEGER jpvt(n) * * Let qr be the (possibly partial) QR-factorization of a matrix B, * i.e. the upper triangle of qr(1:k,1:k) is a partial triangular * factor and the entries below the diagonal in the first k columns * are the Householder vectors. The rest of qr contains a partially * updated matrix. * The vector tau contain the particulars of the Householder matrices. * jpvt contains the pivot inFORMATion * The required workspace is: m+n. * * This FUNCTION returns || Q'A*P - R|| * REAL ZERO PARAMETER ( ZERO = 0.0E+0 ) INTEGER i, j, info REAL aux EXTERNAL Sorm2r, Scopy, Snrm2 REAL Snrm2 INTRINSIC sqrt aux = ZERO DO 10 j = 1, n * Compute j-th column of Q'*A*P and put into vector work(1:m). CALL Scopy( m,a(1,jpvt(j)),1,work(1),1) CALL Sorm2r( 'left','transpose', m, 1, k, qr, ldq, tau, $ work( 1 ), m, work( m+1 ), info ) * Substract j-th column of Q'*A*P and j-th column of R * (stored in qr). IF( j.gt.k ) then DO 20 i = 1, m work(i) = work(i) - qr(i,j) 20 CONTINUE ELSE DO 30 i = 1, j work(i) = work(i) - qr(i,j) 30 CONTINUE END IF aux = aux + Snrm2(m,work,1) ** 2 10 CONTINUE Sckpqr = sqrt(aux) RETURN END ******************************************************************* LOGICAL FUNCTION find(which,an,lan) INTEGER which, lan, an(lan) * returns TRUE if 'which' is a value in 'an', FALSE otherwise. INTEGER i find = .false. DO 10 i = 1,lan IF( an(i) .eq. which) then find = .true. GOTO 20 END IF 10 CONTINUE 20 RETURN END ********************************************************************* SUBROUTINE iZERO(n,x) INTEGER n, x(n) * ZEROs an n-vector x INTEGER i DO 10 i = 1,n x(i) = 0 10 CONTINUE RETURN END ********************************************************************* SUBROUTINE icopy(n,a,b) INTEGER n, a(n), b(n) * copies vector a into vector b INTEGER i DO 10 i = 1,n b(i) = a(i) 10 CONTINUE RETURN END ********************************************************************* INTEGER FUNCTION SFRANK(S,N,RCOND) INTEGER N REAL S(N), RCOND * * returns MAX { 1 <= i <= n | s(1)/s(i) < 1/RCOND } * The entries of S are assumed to be nonnegative and * monotoniCALLy decreasing. * INTEGER I SFRANK = 1 DO 10 I = N,2,-1 IF( S( 1 )*RCOND.LT.S( I ) ) THEN SFRANK = I GOTO 20 END IF 10 CONTINUE 20 RETURN * * END OF SFRANK * END ********************************************************************* SUBROUTINE Ssort(n,x,incrx,job) INTEGER n, incrx CHARACTER*1 job REAL x(*) * * SUBROUTINE to sort a vector * * On entry: * ======== * * x vector of length n to be sorted * n length of vector * incrx element spacing in x * job = 'i' or 'i' sorts in increasing order * = 'd' or 'd' sorts in decreasing order * otherwise the routine returns without performing * any computation * * On exit: * ======== * * x sorted in the prescribed order * * * EXTERNAL entries * ================ * LOGICAL lsame EXTERNAL lsame * * internal variables * ================== * INTEGER i, curelt, nextelt, switch,k REAL temp switch = 0 IF( lsame(job,'i')) switch = 1 IF( lsame(job,'d')) switch = 2 IF( switch .eq. 0) RETURN GOTO (100,200) switch * * sort in increasing order * 100 DO 10 i = n-1,1,-1 k = i 20 IF( k .eq. n) GOTO 10 curelt = 1+(k-1)*incrx nextelt = 1 + k*incrx IF( x(curelt) .le. x(nextelt)) then GOTO 10 ELSE temp = x(curelt) x(curelt) = x(nextelt) x(nextelt) = temp END IF k = k+1 GOTO 20 10 CONTINUE RETURN * * sort in decreasing order * 200 DO 30 i = n-1,1,-1 k = i 40 IF( k .eq. n) GOTO 30 curelt = 1+(k-1)*incrx nextelt = 1 + k*incrx IF( x(curelt) .ge. x(nextelt)) then GOTO 30 ELSE temp = x(curelt) x(curelt) = x(nextelt) x(nextelt) = temp END IF k = k+1 GOTO 40 30 CONTINUE RETURN * * next line is last line of SUBROUTINE Ssort END ********************************************************************* SUBROUTINE isort(n,ix,job) INTEGER n CHARACTER*1 job INTEGER ix(*) * * SUBROUTINE to sort a vector of INTEGERs * * On entry: * ======== * * ix vector of length n to be sorted * n length of vector * job = 'i' or 'i' sorts in increasing order * = 'd' or 'd' sorts in decreasing order * otherwise the routine returns without performing * any computation * * On exit: * ======== * * ix sorted in the prescribed order * * EXTERNALs: * ========= * LOGICAL lsame EXTERNAL lsame * * internal variables * ================== * INTEGER i, curelt, nextelt, switch, k, temp switch = 0 IF( lsame(job,'i')) switch = 1 IF( lsame(job,'d')) switch = 2 IF( switch .eq. 0) RETURN GOTO (100,200) switch * * sort in increasing order * 100 DO 10 i = n-1,1,-1 k = i 20 IF( k .eq. n) GOTO 10 curelt = 1+(k-1) nextelt = 1 + k IF( ix(curelt) .le. ix(nextelt)) then GOTO 10 ELSE temp = ix(curelt) ix(curelt) = ix(nextelt) ix(nextelt) = temp END IF k = k+1 GOTO 20 10 CONTINUE RETURN * * sort in decreasing order * 200 DO 30 i = n-1,1,-1 k = i 40 IF( k .eq. n) GOTO 30 curelt = 1+(k-1) nextelt = 1 + k IF( ix(curelt) .ge. ix(nextelt)) then GOTO 30 ELSE temp = ix(curelt) ix(curelt) = ix(nextelt) ix(nextelt) = temp END IF k = k+1 GOTO 40 30 CONTINUE RETURN * * next line is last line of SUBROUTINE isort END ********************************************************************* SUBROUTINE Sqrdc(x,ldx,n,p,qraux,jpvt,work,job) INTEGER ldx,n,p,job INTEGER jpvt(p) REAL x(ldx,p),qraux(p),work(p) c c sqrdc uses householder transFORMATions to compute the qr c factorization of an n by p matrix x. column pivoting c based on the 2-norms of the reduced columns may be c performed at the users option. c c On entry c c x REAL(ldx,p), where ldx .ge. n. c x contains the matrix whose decomposition is to be c computed. c c ldx INTEGER. c ldx is the leading dimension of the array x. c c n INTEGER. c n is the number of rows of the matrix x. c c p INTEGER. c p is the number of columns of the matrix x. c c jpvt INTEGER(p). c jpvt contains INTEGERs that control the selection c of the pivot columns. the k-th column x(k) of x c is placed in ONE of three classes according to the c value of jpvt(k). c c if jpvt(k) .gt. 0, then x(k) is an initial c column. c c if jpvt(k) .eq. 0, then x(k) is a free column. c c if jpvt(k) .lt. 0, then x(k) is a final column. c c before the decomposition is computed, initial columns c are moved to the beginning of the array x and final c columns to the END. both initial and final columns c are frozen in place during the computation and only c free columns are moved. at the k-th stage of the c reduction, if x(k) is occupied by a free column c it is interchanged with the free column of largest c reduced norm. jpvt is not referenced if c job .eq. 0. c c work REAL(p). c work is a work array. work is not referenced if c job .eq. 0. c c job INTEGER. c job is an INTEGER that initiates column pivoting. c if job .eq. 0, no pivoting is DOne. c if job .ne. 0, pivoting is DOne. c c On RETURN c c x x contains in its upper triangle the upper c triangular matrix r of the qr factorization. c below its diagonal x contains inFORMATion from c which the orthogonal part of the decomposition c can be recovered. note that if pivoting has c been requested, the decomposition is not that c of the original matrix x but that of x c with its columns permuted as described by jpvt. c c qraux REAL(p). c qraux contains further inFORMATion required to recover c the orthogonal part of the decomposition. c c jpvt jpvt(k) contains the index of the column of the c original matrix that has been interchanged into c the k-th column, if pivoting was requested. c c linpack. this version dated 08/14/78 . c g.w. stewart, university of maryland, argonne national lab. c c sqrdc uses the following functions and subprograms. c c blas saxpy,sDOt,sscal,sswap,snrm2 c fortran ABS,MAX,min0,sqrt c c internal variables c REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) c INTEGER j,jp,l,lp1,lup,maxj,pl,pu,jj REAL maxnrm,Snrm2,tt REAL SDOt,nrmxl,t LOGICAL negj,swapj c c pl = 1 pu = 0 IF( job .eq. 0) GOTO 60 c c pivoting has been requested. rearrange the columns c according to jpvt. c DO 20 j = 1, p swapj = jpvt(j) .gt. 0 negj = jpvt(j) .lt. 0 jpvt(j) = j IF( negj) jpvt(j) = -j IF( .not.swapj) GOTO 10 IF( j .ne. pl) CALL Sswap(n,x(1,pl),1,x(1,j),1) jpvt(j) = jpvt(pl) jpvt(pl) = j pl = pl + 1 10 CONTINUE 20 CONTINUE pu = p DO 50 jj = 1, p j = p - jj + 1 IF( jpvt(j) .ge. 0) GOTO 40 jpvt(j) = -jpvt(j) IF( j .eq. pu) GOTO 30 CALL Sswap(n,x(1,pu),1,x(1,j),1) jp = jpvt(pu) jpvt(pu) = jpvt(j) jpvt(j) = jp 30 CONTINUE pu = pu - 1 40 CONTINUE 50 CONTINUE 60 CONTINUE c c compute the norms of the free columns. c IF( pu .lt. pl) GOTO 80 DO 70 j = pl, pu qraux(j) = Snrm2(n,x(1,j),1) work(j) = qraux(j) 70 CONTINUE 80 CONTINUE c c perform the householder reduction of x. c lup = min0(n,p) DO 200 l = 1, lup IF( l .lt. pl .or. l .ge. pu) GOTO 120 c c locate the column of largest norm and bring it c into the pivot position. c maxnrm = 0.0 maxj = l DO 100 j = l, pu IF( qraux(j) .le. maxnrm) GOTO 90 maxnrm = qraux(j) maxj = j 90 CONTINUE 100 CONTINUE IF( maxj .eq. l) GOTO 110 CALL Sswap(n,x(1,l),1,x(1,maxj),1) qraux(maxj) = qraux(l) work(maxj) = work(l) jp = jpvt(maxj) jpvt(maxj) = jpvt(l) jpvt(l) = jp 110 CONTINUE 120 CONTINUE qraux(l) = ZERO IF( l .eq. n) GOTO 190 c c compute the householder transFORMATion for column l. c nrmxl = Snrm2(n-l+1,x(l,l),1) IF( nrmxl .eq. ZERO) GOTO 180 IF( x(l,l) .ne. ZERO) nrmxl = sign(nrmxl,x(l,l)) CALL Sscal(n-l+1,ONE/nrmxl,x(l,l),1) x(l,l) = ONE + x(l,l) c c apply the transFORMATion to the remaining columns, c updating the norms. c lp1 = l + 1 IF( p .lt. lp1) GOTO 170 DO 160 j = lp1, p t = - SDOT(n-l+1,x(l,l),1,x(l,j),1)/x(l,l) CALL Saxpy(n-l+1,t,x(l,l),1,x(l,j),1) IF( j .lt. pl .or. j .gt. pu) GOTO 150 IF( qraux(j) .eq. ZERO) GOTO 150 tt = ONE - (ABS(x(l,j))/qraux(j))**2 tt = MAX(tt,ZERO) t = tt tt = ONE + 0.05*tt*(qraux(j)/work(j))**2 IF( tt .eq. ONE) GOTO 130 qraux(j) = qraux(j)*sqrt(t) GOTO 140 130 CONTINUE qraux(j) = Snrm2(n-l,x(l+1,j),1) work(j) = qraux(j) 140 CONTINUE 150 CONTINUE 160 CONTINUE 170 CONTINUE c c save the transFORMATion. c qraux(l) = x(l,l) x(l,l) = -nrmxl 180 CONTINUE 190 CONTINUE 200 CONTINUE RETURN END ********************************************************************** SHAR_EOF fi # end of overwriting check cd .. cd .. # End of shell archive exit 0